home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / pp.c < prev    next >
C/C++ Source or Header  |  2000-03-20  |  107KB  |  5,291 lines
  1. /*    pp.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.  * "It's a big house this, and very peculiar.  Always a bit more to discover,
  12.  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
  13.  */
  14.  
  15. #include "EXTERN.h"
  16. #define PERL_IN_PP_C
  17. #include "perl.h"
  18.  
  19. /*
  20.  * The compiler on Concurrent CX/UX systems has a subtle bug which only
  21.  * seems to show up when compiling pp.c - it generates the wrong double
  22.  * precision constant value for (double)UV_MAX when used inline in the body
  23.  * of the code below, so this makes a static variable up front (which the
  24.  * compiler seems to get correct) and uses it in place of UV_MAX below.
  25.  */
  26. #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  27. static double UV_MAX_cxux = ((double)UV_MAX);
  28. #endif
  29.  
  30. /*
  31.  * Offset for integer pack/unpack.
  32.  *
  33.  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  34.  * which for now are all Crays, pack and unpack have to play games.
  35.  */
  36.  
  37. /*
  38.  * These values are required for portability of pack() output.
  39.  * If they're not right on your machine, then pack() and unpack()
  40.  * wouldn't work right anyway; you'll need to apply the Cray hack.
  41.  * (I'd like to check them with #if, but you can't use sizeof() in
  42.  * the preprocessor.)  --???
  43.  */
  44. /*
  45.     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  46.     defines are now in config.h.  --Andy Dougherty  April 1998
  47.  */
  48. #define SIZE16 2
  49. #define SIZE32 4
  50.  
  51. /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
  52.    --jhi Feb 1999 */
  53.  
  54. #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
  55. #   define PERL_NATINT_PACK
  56. #endif
  57.  
  58. #if LONGSIZE > 4 && defined(_CRAY)
  59. #  if BYTEORDER == 0x12345678
  60. #    define OFF16(p)    (char*)(p)
  61. #    define OFF32(p)    (char*)(p)
  62. #  else
  63. #    if BYTEORDER == 0x87654321
  64. #      define OFF16(p)    ((char*)(p) + (sizeof(U16) - SIZE16))
  65. #      define OFF32(p)    ((char*)(p) + (sizeof(U32) - SIZE32))
  66. #    else
  67.        }}}} bad cray byte order
  68. #    endif
  69. #  endif
  70. #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
  71. #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
  72. #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
  73. #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
  74. #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
  75. #else
  76. #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
  77. #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
  78. #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
  79. #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
  80. #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
  81. #endif
  82.  
  83. /* variations on pp_null */
  84.  
  85. #ifdef I_UNISTD
  86. #include <unistd.h>
  87. #endif
  88.  
  89. /* XXX I can't imagine anyone who doesn't have this actually _needs_
  90.    it, since pid_t is an integral type.
  91.    --AD  2/20/1998
  92. */
  93. #ifdef NEED_GETPID_PROTO
  94. extern Pid_t getpid (void);
  95. #endif
  96.  
  97. PP(pp_stub)
  98. {
  99.     djSP;
  100.     if (GIMME_V == G_SCALAR)
  101.     XPUSHs(&PL_sv_undef);
  102.     RETURN;
  103. }
  104.  
  105. PP(pp_scalar)
  106. {
  107.     return NORMAL;
  108. }
  109.  
  110. /* Pushy stuff. */
  111.  
  112. PP(pp_padav)
  113. {
  114.     djSP; dTARGET;
  115.     if (PL_op->op_private & OPpLVAL_INTRO)
  116.     SAVECLEARSV(PL_curpad[PL_op->op_targ]);
  117.     EXTEND(SP, 1);
  118.     if (PL_op->op_flags & OPf_REF) {
  119.     PUSHs(TARG);
  120.     RETURN;
  121.     }
  122.     if (GIMME == G_ARRAY) {
  123.     I32 maxarg = AvFILL((AV*)TARG) + 1;
  124.     EXTEND(SP, maxarg);
  125.     if (SvMAGICAL(TARG)) {
  126.         U32 i;
  127.         for (i=0; i < maxarg; i++) {
  128.         SV **svp = av_fetch((AV*)TARG, i, FALSE);
  129.         SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  130.         }
  131.     }
  132.     else {
  133.         Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
  134.     }
  135.     SP += maxarg;
  136.     }
  137.     else {
  138.     SV* sv = sv_newmortal();
  139.     I32 maxarg = AvFILL((AV*)TARG) + 1;
  140.     sv_setiv(sv, maxarg);
  141.     PUSHs(sv);
  142.     }
  143.     RETURN;
  144. }
  145.  
  146. PP(pp_padhv)
  147. {
  148.     djSP; dTARGET;
  149.     I32 gimme;
  150.  
  151.     XPUSHs(TARG);
  152.     if (PL_op->op_private & OPpLVAL_INTRO)
  153.     SAVECLEARSV(PL_curpad[PL_op->op_targ]);
  154.     if (PL_op->op_flags & OPf_REF)
  155.     RETURN;
  156.     gimme = GIMME_V;
  157.     if (gimme == G_ARRAY) {
  158.     RETURNOP(do_kv());
  159.     }
  160.     else if (gimme == G_SCALAR) {
  161.     SV* sv = sv_newmortal();
  162.     if (HvFILL((HV*)TARG))
  163.         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
  164.               (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
  165.     else
  166.         sv_setiv(sv, 0);
  167.     SETs(sv);
  168.     }
  169.     RETURN;
  170. }
  171.  
  172. PP(pp_padany)
  173. {
  174.     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
  175. }
  176.  
  177. /* Translations. */
  178.  
  179. PP(pp_rv2gv)
  180. {
  181.     djSP; dTOPss;  
  182.  
  183.     if (SvROK(sv)) {
  184.       wasref:
  185.     tryAMAGICunDEREF(to_gv);
  186.  
  187.     sv = SvRV(sv);
  188.     if (SvTYPE(sv) == SVt_PVIO) {
  189.         GV *gv = (GV*) sv_newmortal();
  190.         gv_init(gv, 0, "", 0, 0);
  191.         GvIOp(gv) = (IO *)sv;
  192.         (void)SvREFCNT_inc(sv);
  193.         sv = (SV*) gv;
  194.     }
  195.     else if (SvTYPE(sv) != SVt_PVGV)
  196.         DIE(aTHX_ "Not a GLOB reference");
  197.     }
  198.     else {
  199.     if (SvTYPE(sv) != SVt_PVGV) {
  200.         char *sym;
  201.         STRLEN n_a;
  202.  
  203.         if (SvGMAGICAL(sv)) {
  204.         mg_get(sv);
  205.         if (SvROK(sv))
  206.             goto wasref;
  207.         }
  208.         if (!SvOK(sv) && sv != &PL_sv_undef) {
  209.         /* If this is a 'my' scalar and flag is set then vivify 
  210.          * NI-S 1999/05/07
  211.          */ 
  212.         if (PL_op->op_private & OPpDEREF) {
  213.             char *name;
  214.             GV *gv;
  215.             if (cUNOP->op_targ) {
  216.             STRLEN len;
  217.             SV *namesv = PL_curpad[cUNOP->op_targ];
  218.             name = SvPV(namesv, len);
  219.             gv = (GV*)NEWSV(0,0);
  220.             gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
  221.             }
  222.             else {
  223.             name = CopSTASHPV(PL_curcop);
  224.             gv = newGVgen(name);
  225.             }
  226.             sv_upgrade(sv, SVt_RV);
  227.             SvRV(sv) = (SV*)gv;
  228.             SvROK_on(sv);
  229.             SvSETMAGIC(sv);
  230.             goto wasref;
  231.         }
  232.         if (PL_op->op_flags & OPf_REF ||
  233.             PL_op->op_private & HINT_STRICT_REFS)
  234.             DIE(aTHX_ PL_no_usym, "a symbol");
  235.         if (ckWARN(WARN_UNINITIALIZED))
  236.             report_uninit();
  237.         RETSETUNDEF;
  238.         }
  239.         sym = SvPV(sv, n_a);
  240.         if ((PL_op->op_flags & OPf_SPECIAL) &&
  241.         !(PL_op->op_flags & OPf_MOD))
  242.         {
  243.         sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
  244.         if (!sv)
  245.             RETSETUNDEF;
  246.         }
  247.         else {
  248.         if (PL_op->op_private & HINT_STRICT_REFS)
  249.             DIE(aTHX_ PL_no_symref, sym, "a symbol");
  250.         sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
  251.         }
  252.     }
  253.     }
  254.     if (PL_op->op_private & OPpLVAL_INTRO)
  255.     save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
  256.     SETs(sv);
  257.     RETURN;
  258. }
  259.  
  260. PP(pp_rv2sv)
  261. {
  262.     djSP; dTOPss;
  263.  
  264.     if (SvROK(sv)) {
  265.       wasref:
  266.     tryAMAGICunDEREF(to_sv);
  267.  
  268.     sv = SvRV(sv);
  269.     switch (SvTYPE(sv)) {
  270.     case SVt_PVAV:
  271.     case SVt_PVHV:
  272.     case SVt_PVCV:
  273.         DIE(aTHX_ "Not a SCALAR reference");
  274.     }
  275.     }
  276.     else {
  277.     GV *gv = (GV*)sv;
  278.     char *sym;
  279.     STRLEN n_a;
  280.  
  281.     if (SvTYPE(gv) != SVt_PVGV) {
  282.         if (SvGMAGICAL(sv)) {
  283.         mg_get(sv);
  284.         if (SvROK(sv))
  285.             goto wasref;
  286.         }
  287.         if (!SvOK(sv)) {
  288.         if (PL_op->op_flags & OPf_REF ||
  289.             PL_op->op_private & HINT_STRICT_REFS)
  290.             DIE(aTHX_ PL_no_usym, "a SCALAR");
  291.         if (ckWARN(WARN_UNINITIALIZED))
  292.             report_uninit();
  293.         RETSETUNDEF;
  294.         }
  295.         sym = SvPV(sv, n_a);
  296.         if ((PL_op->op_flags & OPf_SPECIAL) &&
  297.         !(PL_op->op_flags & OPf_MOD))
  298.         {
  299.         gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
  300.         if (!gv)
  301.             RETSETUNDEF;
  302.         }
  303.         else {
  304.         if (PL_op->op_private & HINT_STRICT_REFS)
  305.             DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
  306.         gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
  307.         }
  308.     }
  309.     sv = GvSV(gv);
  310.     }
  311.     if (PL_op->op_flags & OPf_MOD) {
  312.     if (PL_op->op_private & OPpLVAL_INTRO)
  313.         sv = save_scalar((GV*)TOPs);
  314.     else if (PL_op->op_private & OPpDEREF)
  315.         vivify_ref(sv, PL_op->op_private & OPpDEREF);
  316.     }
  317.     SETs(sv);
  318.     RETURN;
  319. }
  320.  
  321. PP(pp_av2arylen)
  322. {
  323.     djSP;
  324.     AV *av = (AV*)TOPs;
  325.     SV *sv = AvARYLEN(av);
  326.     if (!sv) {
  327.     AvARYLEN(av) = sv = NEWSV(0,0);
  328.     sv_upgrade(sv, SVt_IV);
  329.     sv_magic(sv, (SV*)av, '#', Nullch, 0);
  330.     }
  331.     SETs(sv);
  332.     RETURN;
  333. }
  334.  
  335. PP(pp_pos)
  336. {
  337.     djSP; dTARGET; dPOPss;
  338.  
  339.     if (PL_op->op_flags & OPf_MOD) {
  340.     if (SvTYPE(TARG) < SVt_PVLV) {
  341.         sv_upgrade(TARG, SVt_PVLV);
  342.         sv_magic(TARG, Nullsv, '.', Nullch, 0);
  343.     }
  344.  
  345.     LvTYPE(TARG) = '.';
  346.     if (LvTARG(TARG) != sv) {
  347.         if (LvTARG(TARG))
  348.         SvREFCNT_dec(LvTARG(TARG));
  349.         LvTARG(TARG) = SvREFCNT_inc(sv);
  350.     }
  351.     PUSHs(TARG);    /* no SvSETMAGIC */
  352.     RETURN;
  353.     }
  354.     else {
  355.     MAGIC* mg;
  356.  
  357.     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
  358.         mg = mg_find(sv, 'g');
  359.         if (mg && mg->mg_len >= 0) {
  360.         I32 i = mg->mg_len;
  361.         if (DO_UTF8(sv))
  362.             sv_pos_b2u(sv, &i);
  363.         PUSHi(i + PL_curcop->cop_arybase);
  364.         RETURN;
  365.         }
  366.     }
  367.     RETPUSHUNDEF;
  368.     }
  369. }
  370.  
  371. PP(pp_rv2cv)
  372. {
  373.     djSP;
  374.     GV *gv;
  375.     HV *stash;
  376.  
  377.     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
  378.     /* (But not in defined().) */
  379.     CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
  380.     if (cv) {
  381.     if (CvCLONE(cv))
  382.         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
  383.     if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
  384.         DIE(aTHX_ "Can't modify non-lvalue subroutine call");
  385.     }
  386.     else
  387.     cv = (CV*)&PL_sv_undef;
  388.     SETs((SV*)cv);
  389.     RETURN;
  390. }
  391.  
  392. PP(pp_prototype)
  393. {
  394.     djSP;
  395.     CV *cv;
  396.     HV *stash;
  397.     GV *gv;
  398.     SV *ret;
  399.  
  400.     ret = &PL_sv_undef;
  401.     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
  402.     char *s = SvPVX(TOPs);
  403.     if (strnEQ(s, "CORE::", 6)) {
  404.         int code;
  405.         
  406.         code = keyword(s + 6, SvCUR(TOPs) - 6);
  407.         if (code < 0) {    /* Overridable. */
  408. #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
  409.         int i = 0, n = 0, seen_question = 0;
  410.         I32 oa;
  411.         char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
  412.  
  413.         while (i < MAXO) {    /* The slow way. */
  414.             if (strEQ(s + 6, PL_op_name[i])
  415.             || strEQ(s + 6, PL_op_desc[i]))
  416.             {
  417.             goto found;
  418.             }
  419.             i++;
  420.         }
  421.         goto nonesuch;        /* Should not happen... */
  422.           found:
  423.         oa = PL_opargs[i] >> OASHIFT;
  424.         while (oa) {
  425.             if (oa & OA_OPTIONAL) {
  426.             seen_question = 1;
  427.             str[n++] = ';';
  428.             }
  429.             else if (n && str[0] == ';' && seen_question) 
  430.             goto set;    /* XXXX system, exec */
  431.             if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 
  432.             && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
  433.             str[n++] = '\\';
  434.             }
  435.             /* What to do with R ((un)tie, tied, (sys)read, recv)? */
  436.             str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
  437.             oa = oa >> 4;
  438.         }
  439.         str[n++] = '\0';
  440.         ret = sv_2mortal(newSVpvn(str, n - 1));
  441.         }
  442.         else if (code)        /* Non-Overridable */
  443.         goto set;
  444.         else {            /* None such */
  445.           nonesuch:
  446.         DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
  447.         }
  448.     }
  449.     }
  450.     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
  451.     if (cv && SvPOK(cv))
  452.     ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
  453.   set:
  454.     SETs(ret);
  455.     RETURN;
  456. }
  457.  
  458. PP(pp_anoncode)
  459. {
  460.     djSP;
  461.     CV* cv = (CV*)PL_curpad[PL_op->op_targ];
  462.     if (CvCLONE(cv))
  463.     cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
  464.     EXTEND(SP,1);
  465.     PUSHs((SV*)cv);
  466.     RETURN;
  467. }
  468.  
  469. PP(pp_srefgen)
  470. {
  471.     djSP;
  472.     *SP = refto(*SP);
  473.     RETURN;
  474. }
  475.  
  476. PP(pp_refgen)
  477. {
  478.     djSP; dMARK;
  479.     if (GIMME != G_ARRAY) {
  480.     if (++MARK <= SP)
  481.         *MARK = *SP;
  482.     else
  483.         *MARK = &PL_sv_undef;
  484.     *MARK = refto(*MARK);
  485.     SP = MARK;
  486.     RETURN;
  487.     }
  488.     EXTEND_MORTAL(SP - MARK);
  489.     while (++MARK <= SP)
  490.     *MARK = refto(*MARK);
  491.     RETURN;
  492. }
  493.  
  494. STATIC SV*
  495. S_refto(pTHX_ SV *sv)
  496. {
  497.     SV* rv;
  498.  
  499.     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
  500.     if (LvTARGLEN(sv))
  501.         vivify_defelem(sv);
  502.     if (!(sv = LvTARG(sv)))
  503.         sv = &PL_sv_undef;
  504.     else
  505.         (void)SvREFCNT_inc(sv);
  506.     }
  507.     else if (SvTYPE(sv) == SVt_PVAV) {
  508.     if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
  509.         av_reify((AV*)sv);
  510.     SvTEMP_off(sv);
  511.     (void)SvREFCNT_inc(sv);
  512.     }
  513.     else if (SvPADTMP(sv))
  514.     sv = newSVsv(sv);
  515.     else {
  516.     SvTEMP_off(sv);
  517.     (void)SvREFCNT_inc(sv);
  518.     }
  519.     rv = sv_newmortal();
  520.     sv_upgrade(rv, SVt_RV);
  521.     SvRV(rv) = sv;
  522.     SvROK_on(rv);
  523.     return rv;
  524. }
  525.  
  526. PP(pp_ref)
  527. {
  528.     djSP; dTARGET;
  529.     SV *sv;
  530.     char *pv;
  531.  
  532.     sv = POPs;
  533.  
  534.     if (sv && SvGMAGICAL(sv))
  535.     mg_get(sv);
  536.  
  537.     if (!sv || !SvROK(sv))
  538.     RETPUSHNO;
  539.  
  540.     sv = SvRV(sv);
  541.     pv = sv_reftype(sv,TRUE);
  542.     PUSHp(pv, strlen(pv));
  543.     RETURN;
  544. }
  545.  
  546. PP(pp_bless)
  547. {
  548.     djSP;
  549.     HV *stash;
  550.  
  551.     if (MAXARG == 1)
  552.     stash = CopSTASH(PL_curcop);
  553.     else {
  554.     SV *ssv = POPs;
  555.     STRLEN len;
  556.     char *ptr = SvPV(ssv,len);
  557.     if (ckWARN(WARN_MISC) && len == 0)
  558.         Perl_warner(aTHX_ WARN_MISC, 
  559.            "Explicit blessing to '' (assuming package main)");
  560.     stash = gv_stashpvn(ptr, len, TRUE);
  561.     }
  562.  
  563.     (void)sv_bless(TOPs, stash);
  564.     RETURN;
  565. }
  566.  
  567. PP(pp_gelem)
  568. {
  569.     GV *gv;
  570.     SV *sv;
  571.     SV *tmpRef;
  572.     char *elem;
  573.     djSP;
  574.     STRLEN n_a;
  575.  
  576.     sv = POPs;
  577.     elem = SvPV(sv, n_a);
  578.     gv = (GV*)POPs;
  579.     tmpRef = Nullsv;
  580.     sv = Nullsv;
  581.     switch (elem ? *elem : '\0')
  582.     {
  583.     case 'A':
  584.     if (strEQ(elem, "ARRAY"))
  585.         tmpRef = (SV*)GvAV(gv);
  586.     break;
  587.     case 'C':
  588.     if (strEQ(elem, "CODE"))
  589.         tmpRef = (SV*)GvCVu(gv);
  590.     break;
  591.     case 'F':
  592.     if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
  593.         tmpRef = (SV*)GvIOp(gv);
  594.     break;
  595.     case 'G':
  596.     if (strEQ(elem, "GLOB"))
  597.         tmpRef = (SV*)gv;
  598.     break;
  599.     case 'H':
  600.     if (strEQ(elem, "HASH"))
  601.         tmpRef = (SV*)GvHV(gv);
  602.     break;
  603.     case 'I':
  604.     if (strEQ(elem, "IO"))
  605.         tmpRef = (SV*)GvIOp(gv);
  606.     break;
  607.     case 'N':
  608.     if (strEQ(elem, "NAME"))
  609.         sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
  610.     break;
  611.     case 'P':
  612.     if (strEQ(elem, "PACKAGE"))
  613.         sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
  614.     break;
  615.     case 'S':
  616.     if (strEQ(elem, "SCALAR"))
  617.         tmpRef = GvSV(gv);
  618.     break;
  619.     }
  620.     if (tmpRef)
  621.     sv = newRV(tmpRef);
  622.     if (sv)
  623.     sv_2mortal(sv);
  624.     else
  625.     sv = &PL_sv_undef;
  626.     XPUSHs(sv);
  627.     RETURN;
  628. }
  629.  
  630. /* Pattern matching */
  631.  
  632. PP(pp_study)
  633. {
  634.     djSP; dPOPss;
  635.     register unsigned char *s;
  636.     register I32 pos;
  637.     register I32 ch;
  638.     register I32 *sfirst;
  639.     register I32 *snext;
  640.     STRLEN len;
  641.  
  642.     if (sv == PL_lastscream) {
  643.     if (SvSCREAM(sv))
  644.         RETPUSHYES;
  645.     }
  646.     else {
  647.     if (PL_lastscream) {
  648.         SvSCREAM_off(PL_lastscream);
  649.         SvREFCNT_dec(PL_lastscream);
  650.     }
  651.     PL_lastscream = SvREFCNT_inc(sv);
  652.     }
  653.  
  654.     s = (unsigned char*)(SvPV(sv, len));
  655.     pos = len;
  656.     if (pos <= 0)
  657.     RETPUSHNO;
  658.     if (pos > PL_maxscream) {
  659.     if (PL_maxscream < 0) {
  660.         PL_maxscream = pos + 80;
  661.         New(301, PL_screamfirst, 256, I32);
  662.         New(302, PL_screamnext, PL_maxscream, I32);
  663.     }
  664.     else {
  665.         PL_maxscream = pos + pos / 4;
  666.         Renew(PL_screamnext, PL_maxscream, I32);
  667.     }
  668.     }
  669.  
  670.     sfirst = PL_screamfirst;
  671.     snext = PL_screamnext;
  672.  
  673.     if (!sfirst || !snext)
  674.     DIE(aTHX_ "do_study: out of memory");
  675.  
  676.     for (ch = 256; ch; --ch)
  677.     *sfirst++ = -1;
  678.     sfirst -= 256;
  679.  
  680.     while (--pos >= 0) {
  681.     ch = s[pos];
  682.     if (sfirst[ch] >= 0)
  683.         snext[pos] = sfirst[ch] - pos;
  684.     else
  685.         snext[pos] = -pos;
  686.     sfirst[ch] = pos;
  687.     }
  688.  
  689.     SvSCREAM_on(sv);
  690.     sv_magic(sv, Nullsv, 'g', Nullch, 0);    /* piggyback on m//g magic */
  691.     RETPUSHYES;
  692. }
  693.  
  694. PP(pp_trans)
  695. {
  696.     djSP; dTARG;
  697.     SV *sv;
  698.  
  699.     if (PL_op->op_flags & OPf_STACKED)
  700.     sv = POPs;
  701.     else {
  702.     sv = DEFSV;
  703.     EXTEND(SP,1);
  704.     }
  705.     TARG = sv_newmortal();
  706.     PUSHi(do_trans(sv));
  707.     RETURN;
  708. }
  709.  
  710. /* Lvalue operators. */
  711.  
  712. PP(pp_schop)
  713. {
  714.     djSP; dTARGET;
  715.     do_chop(TARG, TOPs);
  716.     SETTARG;
  717.     RETURN;
  718. }
  719.  
  720. PP(pp_chop)
  721. {
  722.     djSP; dMARK; dTARGET;
  723.     while (SP > MARK)
  724.     do_chop(TARG, POPs);
  725.     PUSHTARG;
  726.     RETURN;
  727. }
  728.  
  729. PP(pp_schomp)
  730. {
  731.     djSP; dTARGET;
  732.     SETi(do_chomp(TOPs));
  733.     RETURN;
  734. }
  735.  
  736. PP(pp_chomp)
  737. {
  738.     djSP; dMARK; dTARGET;
  739.     register I32 count = 0;
  740.  
  741.     while (SP > MARK)
  742.     count += do_chomp(POPs);
  743.     PUSHi(count);
  744.     RETURN;
  745. }
  746.  
  747. PP(pp_defined)
  748. {
  749.     djSP;
  750.     register SV* sv;
  751.  
  752.     sv = POPs;
  753.     if (!sv || !SvANY(sv))
  754.     RETPUSHNO;
  755.     switch (SvTYPE(sv)) {
  756.     case SVt_PVAV:
  757.     if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
  758.         RETPUSHYES;
  759.     break;
  760.     case SVt_PVHV:
  761.     if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
  762.         RETPUSHYES;
  763.     break;
  764.     case SVt_PVCV:
  765.     if (CvROOT(sv) || CvXSUB(sv))
  766.         RETPUSHYES;
  767.     break;
  768.     default:
  769.     if (SvGMAGICAL(sv))
  770.         mg_get(sv);
  771.     if (SvOK(sv))
  772.         RETPUSHYES;
  773.     }
  774.     RETPUSHNO;
  775. }
  776.  
  777. PP(pp_undef)
  778. {
  779.     djSP;
  780.     SV *sv;
  781.  
  782.     if (!PL_op->op_private) {
  783.     EXTEND(SP, 1);
  784.     RETPUSHUNDEF;
  785.     }
  786.  
  787.     sv = POPs;
  788.     if (!sv)
  789.     RETPUSHUNDEF;
  790.  
  791.     if (SvTHINKFIRST(sv))
  792.     sv_force_normal(sv);
  793.  
  794.     switch (SvTYPE(sv)) {
  795.     case SVt_NULL:
  796.     break;
  797.     case SVt_PVAV:
  798.     av_undef((AV*)sv);
  799.     break;
  800.     case SVt_PVHV:
  801.     hv_undef((HV*)sv);
  802.     break;
  803.     case SVt_PVCV:
  804.     if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
  805.         Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
  806.          CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
  807.     /* FALL THROUGH */
  808.     case SVt_PVFM:
  809.     {
  810.         /* let user-undef'd sub keep its identity */
  811.         GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
  812.         cv_undef((CV*)sv);
  813.         CvGV((CV*)sv) = gv;
  814.     }
  815.     break;
  816.     case SVt_PVGV:
  817.     if (SvFAKE(sv))
  818.         SvSetMagicSV(sv, &PL_sv_undef);
  819.     else {
  820.         GP *gp;
  821.         gp_free((GV*)sv);
  822.         Newz(602, gp, 1, GP);
  823.         GvGP(sv) = gp_ref(gp);
  824.         GvSV(sv) = NEWSV(72,0);
  825.         GvLINE(sv) = CopLINE(PL_curcop);
  826.         GvEGV(sv) = (GV*)sv;
  827.         GvMULTI_on(sv);
  828.     }
  829.     break;
  830.     default:
  831.     if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
  832.         (void)SvOOK_off(sv);
  833.         Safefree(SvPVX(sv));
  834.         SvPV_set(sv, Nullch);
  835.         SvLEN_set(sv, 0);
  836.     }
  837.     (void)SvOK_off(sv);
  838.     SvSETMAGIC(sv);
  839.     }
  840.  
  841.     RETPUSHUNDEF;
  842. }
  843.  
  844. PP(pp_predec)
  845. {
  846.     djSP;
  847.     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
  848.     DIE(aTHX_ PL_no_modify);
  849.     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
  850.         SvIVX(TOPs) != IV_MIN)
  851.     {
  852.     --SvIVX(TOPs);
  853.     SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
  854.     }
  855.     else
  856.     sv_dec(TOPs);
  857.     SvSETMAGIC(TOPs);
  858.     return NORMAL;
  859. }
  860.  
  861. PP(pp_postinc)
  862. {
  863.     djSP; dTARGET;
  864.     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
  865.     DIE(aTHX_ PL_no_modify);
  866.     sv_setsv(TARG, TOPs);
  867.     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
  868.         SvIVX(TOPs) != IV_MAX)
  869.     {
  870.     ++SvIVX(TOPs);
  871.     SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
  872.     }
  873.     else
  874.     sv_inc(TOPs);
  875.     SvSETMAGIC(TOPs);
  876.     if (!SvOK(TARG))
  877.     sv_setiv(TARG, 0);
  878.     SETs(TARG);
  879.     return NORMAL;
  880. }
  881.  
  882. PP(pp_postdec)
  883. {
  884.     djSP; dTARGET;
  885.     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
  886.     DIE(aTHX_ PL_no_modify);
  887.     sv_setsv(TARG, TOPs);
  888.     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
  889.         SvIVX(TOPs) != IV_MIN)
  890.     {
  891.     --SvIVX(TOPs);
  892.     SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
  893.     }
  894.     else
  895.     sv_dec(TOPs);
  896.     SvSETMAGIC(TOPs);
  897.     SETs(TARG);
  898.     return NORMAL;
  899. }
  900.  
  901. /* Ordinary operators. */
  902.  
  903. PP(pp_pow)
  904. {
  905.     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
  906.     {
  907.       dPOPTOPnnrl;
  908.       SETn( Perl_pow( left, right) );
  909.       RETURN;
  910.     }
  911. }
  912.  
  913. PP(pp_multiply)
  914. {
  915.     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
  916.     {
  917.       dPOPTOPnnrl;
  918.       SETn( left * right );
  919.       RETURN;
  920.     }
  921. }
  922.  
  923. PP(pp_divide)
  924. {
  925.     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
  926.     {
  927.       dPOPPOPnnrl;
  928.       NV value;
  929.       if (right == 0.0)
  930.     DIE(aTHX_ "Illegal division by zero");
  931. #ifdef SLOPPYDIVIDE
  932.       /* insure that 20./5. == 4. */
  933.       {
  934.     IV k;
  935.     if ((NV)I_V(left)  == left &&
  936.         (NV)I_V(right) == right &&
  937.         (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
  938.         value = k;
  939.     }
  940.     else {
  941.         value = left / right;
  942.     }
  943.       }
  944. #else
  945.       value = left / right;
  946. #endif
  947.       PUSHn( value );
  948.       RETURN;
  949.     }
  950. }
  951.  
  952. PP(pp_modulo)
  953. {
  954.     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
  955.     {
  956.     UV left;
  957.     UV right;
  958.     bool left_neg;
  959.     bool right_neg;
  960.     bool use_double = 0;
  961.     NV dright;
  962.     NV dleft;
  963.  
  964.     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
  965.         IV i = SvIVX(POPs);
  966.         right = (right_neg = (i < 0)) ? -i : i;
  967.     }
  968.     else {
  969.         dright = POPn;
  970.         use_double = 1;
  971.         right_neg = dright < 0;
  972.         if (right_neg)
  973.         dright = -dright;
  974.     }
  975.  
  976.     if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
  977.         IV i = SvIVX(POPs);
  978.         left = (left_neg = (i < 0)) ? -i : i;
  979.     }
  980.     else {
  981.         dleft = POPn;
  982.         if (!use_double) {
  983.         use_double = 1;
  984.         dright = right;
  985.         }
  986.         left_neg = dleft < 0;
  987.         if (left_neg)
  988.         dleft = -dleft;
  989.     }
  990.  
  991.     if (use_double) {
  992.         NV dans;
  993.  
  994. #if 1
  995. /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
  996. #  if CASTFLAGS & 2
  997. #    define CAST_D2UV(d) U_V(d)
  998. #  else
  999. #    define CAST_D2UV(d) ((UV)(d))
  1000. #  endif
  1001.         /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
  1002.          * or, in other words, precision of UV more than of NV.
  1003.          * But in fact the approach below turned out to be an
  1004.          * optimization - floor() may be slow */
  1005.         if (dright <= UV_MAX && dleft <= UV_MAX) {
  1006.         right = CAST_D2UV(dright);
  1007.         left  = CAST_D2UV(dleft);
  1008.         goto do_uv;
  1009.         }
  1010. #endif
  1011.  
  1012.         /* Backward-compatibility clause: */
  1013.         dright = Perl_floor(dright + 0.5);
  1014.         dleft  = Perl_floor(dleft + 0.5);
  1015.  
  1016.         if (!dright)
  1017.         DIE(aTHX_ "Illegal modulus zero");
  1018.  
  1019.         dans = Perl_fmod(dleft, dright);
  1020.         if ((left_neg != right_neg) && dans)
  1021.         dans = dright - dans;
  1022.         if (right_neg)
  1023.         dans = -dans;
  1024.         sv_setnv(TARG, dans);
  1025.     }
  1026.     else {
  1027.         UV ans;
  1028.  
  1029.     do_uv:
  1030.         if (!right)
  1031.         DIE(aTHX_ "Illegal modulus zero");
  1032.  
  1033.         ans = left % right;
  1034.         if ((left_neg != right_neg) && ans)
  1035.         ans = right - ans;
  1036.         if (right_neg) {
  1037.         /* XXX may warn: unary minus operator applied to unsigned type */
  1038.         /* could change -foo to be (~foo)+1 instead    */
  1039.         if (ans <= ~((UV)IV_MAX)+1)
  1040.             sv_setiv(TARG, ~ans+1);
  1041.         else
  1042.             sv_setnv(TARG, -(NV)ans);
  1043.         }
  1044.         else
  1045.         sv_setuv(TARG, ans);
  1046.     }
  1047.     PUSHTARG;
  1048.     RETURN;
  1049.     }
  1050. }
  1051.  
  1052. PP(pp_repeat)
  1053. {
  1054.   djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
  1055.   {
  1056.     register I32 count = POPi;
  1057.     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
  1058.     dMARK;
  1059.     I32 items = SP - MARK;
  1060.     I32 max;
  1061.  
  1062.     max = items * count;
  1063.     MEXTEND(MARK, max);
  1064.     if (count > 1) {
  1065.         while (SP > MARK) {
  1066.         if (*SP)
  1067.             SvTEMP_off((*SP));
  1068.         SP--;
  1069.         }
  1070.         MARK++;
  1071.         repeatcpy((char*)(MARK + items), (char*)MARK,
  1072.         items * sizeof(SV*), count - 1);
  1073.         SP += max;
  1074.     }
  1075.     else if (count <= 0)
  1076.         SP -= items;
  1077.     }
  1078.     else {    /* Note: mark already snarfed by pp_list */
  1079.     SV *tmpstr;
  1080.     STRLEN len;
  1081.  
  1082.     tmpstr = POPs;
  1083.     SvSetSV(TARG, tmpstr);
  1084.     SvPV_force(TARG, len);
  1085.     if (count != 1) {
  1086.         if (count < 1)
  1087.         SvCUR_set(TARG, 0);
  1088.         else {
  1089.         SvGROW(TARG, (count * len) + 1);
  1090.         repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
  1091.         SvCUR(TARG) *= count;
  1092.         }
  1093.         *SvEND(TARG) = '\0';
  1094.     }
  1095.     (void)SvPOK_only(TARG);
  1096.     PUSHTARG;
  1097.     }
  1098.     RETURN;
  1099.   }
  1100. }
  1101.  
  1102. PP(pp_subtract)
  1103. {
  1104.     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
  1105.     {
  1106.       dPOPTOPnnrl_ul;
  1107.       SETn( left - right );
  1108.       RETURN;
  1109.     }
  1110. }
  1111.  
  1112. PP(pp_left_shift)
  1113. {
  1114.     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
  1115.     {
  1116.       IV shift = POPi;
  1117.       if (PL_op->op_private & HINT_INTEGER) {
  1118.     IV i = TOPi;
  1119.     SETi(i << shift);
  1120.       }
  1121.       else {
  1122.     UV u = TOPu;
  1123.     SETu(u << shift);
  1124.       }
  1125.       RETURN;
  1126.     }
  1127. }
  1128.  
  1129. PP(pp_right_shift)
  1130. {
  1131.     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
  1132.     {
  1133.       IV shift = POPi;
  1134.       if (PL_op->op_private & HINT_INTEGER) {
  1135.     IV i = TOPi;
  1136.     SETi(i >> shift);
  1137.       }
  1138.       else {
  1139.     UV u = TOPu;
  1140.     SETu(u >> shift);
  1141.       }
  1142.       RETURN;
  1143.     }
  1144. }
  1145.  
  1146. PP(pp_lt)
  1147. {
  1148.     djSP; tryAMAGICbinSET(lt,0);
  1149.     {
  1150.       dPOPnv;
  1151.       SETs(boolSV(TOPn < value));
  1152.       RETURN;
  1153.     }
  1154. }
  1155.  
  1156. PP(pp_gt)
  1157. {
  1158.     djSP; tryAMAGICbinSET(gt,0);
  1159.     {
  1160.       dPOPnv;
  1161.       SETs(boolSV(TOPn > value));
  1162.       RETURN;
  1163.     }
  1164. }
  1165.  
  1166. PP(pp_le)
  1167. {
  1168.     djSP; tryAMAGICbinSET(le,0);
  1169.     {
  1170.       dPOPnv;
  1171.       SETs(boolSV(TOPn <= value));
  1172.       RETURN;
  1173.     }
  1174. }
  1175.  
  1176. PP(pp_ge)
  1177. {
  1178.     djSP; tryAMAGICbinSET(ge,0);
  1179.     {
  1180.       dPOPnv;
  1181.       SETs(boolSV(TOPn >= value));
  1182.       RETURN;
  1183.     }
  1184. }
  1185.  
  1186. PP(pp_ne)
  1187. {
  1188.     djSP; tryAMAGICbinSET(ne,0);
  1189.     {
  1190.       dPOPnv;
  1191.       SETs(boolSV(TOPn != value));
  1192.       RETURN;
  1193.     }
  1194. }
  1195.  
  1196. PP(pp_ncmp)
  1197. {
  1198.     djSP; dTARGET; tryAMAGICbin(ncmp,0);
  1199.     {
  1200.       dPOPTOPnnrl;
  1201.       I32 value;
  1202. #ifdef __osf__ /* XXX Configure probe for isnan and isnanl needed XXX */
  1203. #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
  1204. #define Perl_isnan isnanl
  1205. #else
  1206. #define Perl_isnan isnan
  1207. #endif
  1208. #endif
  1209.  
  1210. #ifdef __osf__ /* XXX fix in 5.6.1 --jhi */
  1211.       if (Perl_isnan(left) || Perl_isnan(right)) {
  1212.       SETs(&PL_sv_undef);
  1213.       RETURN;
  1214.        }
  1215.       value = (left > right) - (left < right);
  1216. #else
  1217.       if (left == right)
  1218.     value = 0;
  1219.       else if (left < right)
  1220.     value = -1;
  1221.       else if (left > right)
  1222.     value = 1;
  1223.       else {
  1224.     SETs(&PL_sv_undef);
  1225.     RETURN;
  1226.       }
  1227. #endif
  1228.       SETi(value);
  1229.       RETURN;
  1230.     }
  1231. }
  1232.  
  1233. PP(pp_slt)
  1234. {
  1235.     djSP; tryAMAGICbinSET(slt,0);
  1236.     {
  1237.       dPOPTOPssrl;
  1238.       int cmp = ((PL_op->op_private & OPpLOCALE)
  1239.          ? sv_cmp_locale(left, right)
  1240.          : sv_cmp(left, right));
  1241.       SETs(boolSV(cmp < 0));
  1242.       RETURN;
  1243.     }
  1244. }
  1245.  
  1246. PP(pp_sgt)
  1247. {
  1248.     djSP; tryAMAGICbinSET(sgt,0);
  1249.     {
  1250.       dPOPTOPssrl;
  1251.       int cmp = ((PL_op->op_private & OPpLOCALE)
  1252.          ? sv_cmp_locale(left, right)
  1253.          : sv_cmp(left, right));
  1254.       SETs(boolSV(cmp > 0));
  1255.       RETURN;
  1256.     }
  1257. }
  1258.  
  1259. PP(pp_sle)
  1260. {
  1261.     djSP; tryAMAGICbinSET(sle,0);
  1262.     {
  1263.       dPOPTOPssrl;
  1264.       int cmp = ((PL_op->op_private & OPpLOCALE)
  1265.          ? sv_cmp_locale(left, right)
  1266.          : sv_cmp(left, right));
  1267.       SETs(boolSV(cmp <= 0));
  1268.       RETURN;
  1269.     }
  1270. }
  1271.  
  1272. PP(pp_sge)
  1273. {
  1274.     djSP; tryAMAGICbinSET(sge,0);
  1275.     {
  1276.       dPOPTOPssrl;
  1277.       int cmp = ((PL_op->op_private & OPpLOCALE)
  1278.          ? sv_cmp_locale(left, right)
  1279.          : sv_cmp(left, right));
  1280.       SETs(boolSV(cmp >= 0));
  1281.       RETURN;
  1282.     }
  1283. }
  1284.  
  1285. PP(pp_seq)
  1286. {
  1287.     djSP; tryAMAGICbinSET(seq,0);
  1288.     {
  1289.       dPOPTOPssrl;
  1290.       SETs(boolSV(sv_eq(left, right)));
  1291.       RETURN;
  1292.     }
  1293. }
  1294.  
  1295. PP(pp_sne)
  1296. {
  1297.     djSP; tryAMAGICbinSET(sne,0);
  1298.     {
  1299.       dPOPTOPssrl;
  1300.       SETs(boolSV(!sv_eq(left, right)));
  1301.       RETURN;
  1302.     }
  1303. }
  1304.  
  1305. PP(pp_scmp)
  1306. {
  1307.     djSP; dTARGET;  tryAMAGICbin(scmp,0);
  1308.     {
  1309.       dPOPTOPssrl;
  1310.       int cmp = ((PL_op->op_private & OPpLOCALE)
  1311.          ? sv_cmp_locale(left, right)
  1312.          : sv_cmp(left, right));
  1313.       SETi( cmp );
  1314.       RETURN;
  1315.     }
  1316. }
  1317.  
  1318. PP(pp_bit_and)
  1319. {
  1320.     djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
  1321.     {
  1322.       dPOPTOPssrl;
  1323.       if (SvNIOKp(left) || SvNIOKp(right)) {
  1324.     if (PL_op->op_private & HINT_INTEGER) {
  1325.       IV i = SvIV(left) & SvIV(right);
  1326.       SETi(i);
  1327.     }
  1328.     else {
  1329.       UV u = SvUV(left) & SvUV(right);
  1330.       SETu(u);
  1331.     }
  1332.       }
  1333.       else {
  1334.     do_vop(PL_op->op_type, TARG, left, right);
  1335.     SETTARG;
  1336.       }
  1337.       RETURN;
  1338.     }
  1339. }
  1340.  
  1341. PP(pp_bit_xor)
  1342. {
  1343.     djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
  1344.     {
  1345.       dPOPTOPssrl;
  1346.       if (SvNIOKp(left) || SvNIOKp(right)) {
  1347.     if (PL_op->op_private & HINT_INTEGER) {
  1348.       IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
  1349.       SETi(i);
  1350.     }
  1351.     else {
  1352.       UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
  1353.       SETu(u);
  1354.     }
  1355.       }
  1356.       else {
  1357.     do_vop(PL_op->op_type, TARG, left, right);
  1358.     SETTARG;
  1359.       }
  1360.       RETURN;
  1361.     }
  1362. }
  1363.  
  1364. PP(pp_bit_or)
  1365. {
  1366.     djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
  1367.     {
  1368.       dPOPTOPssrl;
  1369.       if (SvNIOKp(left) || SvNIOKp(right)) {
  1370.     if (PL_op->op_private & HINT_INTEGER) {
  1371.       IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
  1372.       SETi(i);
  1373.     }
  1374.     else {
  1375.       UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
  1376.       SETu(u);
  1377.     }
  1378.       }
  1379.       else {
  1380.     do_vop(PL_op->op_type, TARG, left, right);
  1381.     SETTARG;
  1382.       }
  1383.       RETURN;
  1384.     }
  1385. }
  1386.  
  1387. PP(pp_negate)
  1388. {
  1389.     djSP; dTARGET; tryAMAGICun(neg);
  1390.     {
  1391.     dTOPss;
  1392.     if (SvGMAGICAL(sv))
  1393.         mg_get(sv);
  1394.     if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
  1395.         if (SvIsUV(sv)) {
  1396.         if (SvIVX(sv) == IV_MIN) {
  1397.             SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
  1398.             RETURN;
  1399.         }
  1400.         else if (SvUVX(sv) <= IV_MAX) {
  1401.             SETi(-SvIVX(sv));
  1402.             RETURN;
  1403.         }
  1404.         }
  1405.         else if (SvIVX(sv) != IV_MIN) {
  1406.         SETi(-SvIVX(sv));
  1407.         RETURN;
  1408.         }
  1409.     }
  1410.     if (SvNIOKp(sv))
  1411.         SETn(-SvNV(sv));
  1412.     else if (SvPOKp(sv)) {
  1413.         STRLEN len;
  1414.         char *s = SvPV(sv, len);
  1415.         if (isIDFIRST(*s)) {
  1416.         sv_setpvn(TARG, "-", 1);
  1417.         sv_catsv(TARG, sv);
  1418.         }
  1419.         else if (*s == '+' || *s == '-') {
  1420.         sv_setsv(TARG, sv);
  1421.         *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
  1422.         }
  1423.         else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
  1424.         sv_setpvn(TARG, "-", 1);
  1425.         sv_catsv(TARG, sv);
  1426.         }
  1427.         else
  1428.         sv_setnv(TARG, -SvNV(sv));
  1429.         SETTARG;
  1430.     }
  1431.     else
  1432.         SETn(-SvNV(sv));
  1433.     }
  1434.     RETURN;
  1435. }
  1436.  
  1437. PP(pp_not)
  1438. {
  1439.     djSP; tryAMAGICunSET(not);
  1440.     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
  1441.     return NORMAL;
  1442. }
  1443.  
  1444. PP(pp_complement)
  1445. {
  1446.     djSP; dTARGET; tryAMAGICun(compl);
  1447.     {
  1448.       dTOPss;
  1449.       if (SvNIOKp(sv)) {
  1450.     if (PL_op->op_private & HINT_INTEGER) {
  1451.       IV i = ~SvIV(sv);
  1452.       SETi(i);
  1453.     }
  1454.     else {
  1455.       UV u = ~SvUV(sv);
  1456.       SETu(u);
  1457.     }
  1458.       }
  1459.       else {
  1460.     register char *tmps;
  1461.     register long *tmpl;
  1462.     register I32 anum;
  1463.     STRLEN len;
  1464.  
  1465.     SvSetSV(TARG, sv);
  1466.     tmps = SvPV_force(TARG, len);
  1467.     anum = len;
  1468. #ifdef LIBERAL
  1469.     for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
  1470.         *tmps = ~*tmps;
  1471.     tmpl = (long*)tmps;
  1472.     for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
  1473.         *tmpl = ~*tmpl;
  1474.     tmps = (char*)tmpl;
  1475. #endif
  1476.     for ( ; anum > 0; anum--, tmps++)
  1477.         *tmps = ~*tmps;
  1478.  
  1479.     SETs(TARG);
  1480.       }
  1481.       RETURN;
  1482.     }
  1483. }
  1484.  
  1485. /* integer versions of some of the above */
  1486.  
  1487. PP(pp_i_multiply)
  1488. {
  1489.     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
  1490.     {
  1491.       dPOPTOPiirl;
  1492.       SETi( left * right );
  1493.       RETURN;
  1494.     }
  1495. }
  1496.  
  1497. PP(pp_i_divide)
  1498. {
  1499.     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
  1500.     {
  1501.       dPOPiv;
  1502.       if (value == 0)
  1503.     DIE(aTHX_ "Illegal division by zero");
  1504.       value = POPi / value;
  1505.       PUSHi( value );
  1506.       RETURN;
  1507.     }
  1508. }
  1509.  
  1510. PP(pp_i_modulo)
  1511. {
  1512.     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 
  1513.     {
  1514.       dPOPTOPiirl;
  1515.       if (!right)
  1516.     DIE(aTHX_ "Illegal modulus zero");
  1517.       SETi( left % right );
  1518.       RETURN;
  1519.     }
  1520. }
  1521.  
  1522. PP(pp_i_add)
  1523. {
  1524.     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
  1525.     {
  1526.       dPOPTOPiirl;
  1527.       SETi( left + right );
  1528.       RETURN;
  1529.     }
  1530. }
  1531.  
  1532. PP(pp_i_subtract)
  1533. {
  1534.     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
  1535.     {
  1536.       dPOPTOPiirl;
  1537.       SETi( left - right );
  1538.       RETURN;
  1539.     }
  1540. }
  1541.  
  1542. PP(pp_i_lt)
  1543. {
  1544.     djSP; tryAMAGICbinSET(lt,0);
  1545.     {
  1546.       dPOPTOPiirl;
  1547.       SETs(boolSV(left < right));
  1548.       RETURN;
  1549.     }
  1550. }
  1551.  
  1552. PP(pp_i_gt)
  1553. {
  1554.     djSP; tryAMAGICbinSET(gt,0);
  1555.     {
  1556.       dPOPTOPiirl;
  1557.       SETs(boolSV(left > right));
  1558.       RETURN;
  1559.     }
  1560. }
  1561.  
  1562. PP(pp_i_le)
  1563. {
  1564.     djSP; tryAMAGICbinSET(le,0);
  1565.     {
  1566.       dPOPTOPiirl;
  1567.       SETs(boolSV(left <= right));
  1568.       RETURN;
  1569.     }
  1570. }
  1571.  
  1572. PP(pp_i_ge)
  1573. {
  1574.     djSP; tryAMAGICbinSET(ge,0);
  1575.     {
  1576.       dPOPTOPiirl;
  1577.       SETs(boolSV(left >= right));
  1578.       RETURN;
  1579.     }
  1580. }
  1581.  
  1582. PP(pp_i_eq)
  1583. {
  1584.     djSP; tryAMAGICbinSET(eq,0);
  1585.     {
  1586.       dPOPTOPiirl;
  1587.       SETs(boolSV(left == right));
  1588.       RETURN;
  1589.     }
  1590. }
  1591.  
  1592. PP(pp_i_ne)
  1593. {
  1594.     djSP; tryAMAGICbinSET(ne,0);
  1595.     {
  1596.       dPOPTOPiirl;
  1597.       SETs(boolSV(left != right));
  1598.       RETURN;
  1599.     }
  1600. }
  1601.  
  1602. PP(pp_i_ncmp)
  1603. {
  1604.     djSP; dTARGET; tryAMAGICbin(ncmp,0);
  1605.     {
  1606.       dPOPTOPiirl;
  1607.       I32 value;
  1608.  
  1609.       if (left > right)
  1610.     value = 1;
  1611.       else if (left < right)
  1612.     value = -1;
  1613.       else
  1614.     value = 0;
  1615.       SETi(value);
  1616.       RETURN;
  1617.     }
  1618. }
  1619.  
  1620. PP(pp_i_negate)
  1621. {
  1622.     djSP; dTARGET; tryAMAGICun(neg);
  1623.     SETi(-TOPi);
  1624.     RETURN;
  1625. }
  1626.  
  1627. /* High falutin' math. */
  1628.  
  1629. PP(pp_atan2)
  1630. {
  1631.     djSP; dTARGET; tryAMAGICbin(atan2,0);
  1632.     {
  1633.       dPOPTOPnnrl;
  1634.       SETn(Perl_atan2(left, right));
  1635.       RETURN;
  1636.     }
  1637. }
  1638.  
  1639. PP(pp_sin)
  1640. {
  1641.     djSP; dTARGET; tryAMAGICun(sin);
  1642.     {
  1643.       NV value;
  1644.       value = POPn;
  1645.       value = Perl_sin(value);
  1646.       XPUSHn(value);
  1647.       RETURN;
  1648.     }
  1649. }
  1650.  
  1651. PP(pp_cos)
  1652. {
  1653.     djSP; dTARGET; tryAMAGICun(cos);
  1654.     {
  1655.       NV value;
  1656.       value = POPn;
  1657.       value = Perl_cos(value);
  1658.       XPUSHn(value);
  1659.       RETURN;
  1660.     }
  1661. }
  1662.  
  1663. /* Support Configure command-line overrides for rand() functions.
  1664.    After 5.005, perhaps we should replace this by Configure support
  1665.    for drand48(), random(), or rand().  For 5.005, though, maintain
  1666.    compatibility by calling rand() but allow the user to override it.
  1667.    See INSTALL for details.  --Andy Dougherty  15 July 1998
  1668. */
  1669. /* Now it's after 5.005, and Configure supports drand48() and random(),
  1670.    in addition to rand().  So the overrides should not be needed any more.
  1671.    --Jarkko Hietaniemi    27 September 1998
  1672.  */
  1673.  
  1674. #ifndef HAS_DRAND48_PROTO
  1675. extern double drand48 (void);
  1676. #endif
  1677.  
  1678. PP(pp_rand)
  1679. {
  1680.     djSP; dTARGET;
  1681.     NV value;
  1682.     if (MAXARG < 1)
  1683.     value = 1.0;
  1684.     else
  1685.     value = POPn;
  1686.     if (value == 0.0)
  1687.     value = 1.0;
  1688.     if (!PL_srand_called) {
  1689.     (void)seedDrand01((Rand_seed_t)seed());
  1690.     PL_srand_called = TRUE;
  1691.     }
  1692.     value *= Drand01();
  1693.     XPUSHn(value);
  1694.     RETURN;
  1695. }
  1696.  
  1697. PP(pp_srand)
  1698. {
  1699.     djSP;
  1700.     UV anum;
  1701.     if (MAXARG < 1)
  1702.     anum = seed();
  1703.     else
  1704.     anum = POPu;
  1705.     (void)seedDrand01((Rand_seed_t)anum);
  1706.     PL_srand_called = TRUE;
  1707.     EXTEND(SP, 1);
  1708.     RETPUSHYES;
  1709. }
  1710.  
  1711. STATIC U32
  1712. S_seed(pTHX)
  1713. {
  1714.     /*
  1715.      * This is really just a quick hack which grabs various garbage
  1716.      * values.  It really should be a real hash algorithm which
  1717.      * spreads the effect of every input bit onto every output bit,
  1718.      * if someone who knows about such things would bother to write it.
  1719.      * Might be a good idea to add that function to CORE as well.
  1720.      * No numbers below come from careful analysis or anything here,
  1721.      * except they are primes and SEED_C1 > 1E6 to get a full-width
  1722.      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
  1723.      * probably be bigger too.
  1724.      */
  1725. #if RANDBITS > 16
  1726. #  define SEED_C1    1000003
  1727. #define   SEED_C4    73819
  1728. #else
  1729. #  define SEED_C1    25747
  1730. #define   SEED_C4    20639
  1731. #endif
  1732. #define   SEED_C2    3
  1733. #define   SEED_C3    269
  1734. #define   SEED_C5    26107
  1735.  
  1736.     dTHR;
  1737. #ifndef PERL_NO_DEV_RANDOM
  1738.     int fd;
  1739. #endif
  1740.     U32 u;
  1741. #ifdef VMS
  1742. #  include <starlet.h>
  1743.     /* when[] = (low 32 bits, high 32 bits) of time since epoch
  1744.      * in 100-ns units, typically incremented ever 10 ms.        */
  1745.     unsigned int when[2];
  1746. #else
  1747. #  ifdef HAS_GETTIMEOFDAY
  1748.     struct timeval when;
  1749. #  else
  1750.     Time_t when;
  1751. #  endif
  1752. #endif
  1753.  
  1754. /* This test is an escape hatch, this symbol isn't set by Configure. */
  1755. #ifndef PERL_NO_DEV_RANDOM
  1756. #ifndef PERL_RANDOM_DEVICE
  1757.    /* /dev/random isn't used by default because reads from it will block
  1758.     * if there isn't enough entropy available.  You can compile with
  1759.     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
  1760.     * is enough real entropy to fill the seed. */
  1761. #  define PERL_RANDOM_DEVICE "/dev/urandom"
  1762. #endif
  1763.     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
  1764.     if (fd != -1) {
  1765.         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
  1766.         u = 0;
  1767.     PerlLIO_close(fd);
  1768.     if (u)
  1769.         return u;
  1770.     }
  1771. #endif
  1772.  
  1773. #ifdef VMS
  1774.     _ckvmssts(sys$gettim(when));
  1775.     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
  1776. #else
  1777. #  ifdef HAS_GETTIMEOFDAY
  1778.     gettimeofday(&when,(struct timezone *) 0);
  1779.     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
  1780. #  else
  1781.     (void)time(&when);
  1782.     u = (U32)SEED_C1 * when;
  1783. #  endif
  1784. #endif
  1785.     u += SEED_C3 * (U32)PerlProc_getpid();
  1786.     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
  1787. #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
  1788.     u += SEED_C5 * (U32)PTR2UV(&when);
  1789. #endif
  1790.     return u;
  1791. }
  1792.  
  1793. PP(pp_exp)
  1794. {
  1795.     djSP; dTARGET; tryAMAGICun(exp);
  1796.     {
  1797.       NV value;
  1798.       value = POPn;
  1799.       value = Perl_exp(value);
  1800.       XPUSHn(value);
  1801.       RETURN;
  1802.     }
  1803. }
  1804.  
  1805. PP(pp_log)
  1806. {
  1807.     djSP; dTARGET; tryAMAGICun(log);
  1808.     {
  1809.       NV value;
  1810.       value = POPn;
  1811.       if (value <= 0.0) {
  1812.     RESTORE_NUMERIC_STANDARD();
  1813.     DIE(aTHX_ "Can't take log of %g", value);
  1814.       }
  1815.       value = Perl_log(value);
  1816.       XPUSHn(value);
  1817.       RETURN;
  1818.     }
  1819. }
  1820.  
  1821. PP(pp_sqrt)
  1822. {
  1823.     djSP; dTARGET; tryAMAGICun(sqrt);
  1824.     {
  1825.       NV value;
  1826.       value = POPn;
  1827.       if (value < 0.0) {
  1828.     RESTORE_NUMERIC_STANDARD();
  1829.     DIE(aTHX_ "Can't take sqrt of %g", value);
  1830.       }
  1831.       value = Perl_sqrt(value);
  1832.       XPUSHn(value);
  1833.       RETURN;
  1834.     }
  1835. }
  1836.  
  1837. PP(pp_int)
  1838. {
  1839.     djSP; dTARGET;
  1840.     {
  1841.       NV value = TOPn;
  1842.       IV iv;
  1843.  
  1844.       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
  1845.     iv = SvIVX(TOPs);
  1846.     SETi(iv);
  1847.       }
  1848.       else {
  1849.     if (value >= 0.0)
  1850.       (void)Perl_modf(value, &value);
  1851.     else {
  1852.       (void)Perl_modf(-value, &value);
  1853.       value = -value;
  1854.     }
  1855.     iv = I_V(value);
  1856.     if (iv == value)
  1857.       SETi(iv);
  1858.     else
  1859.       SETn(value);
  1860.       }
  1861.     }
  1862.     RETURN;
  1863. }
  1864.  
  1865. PP(pp_abs)
  1866. {
  1867.     djSP; dTARGET; tryAMAGICun(abs);
  1868.     {
  1869.       NV value = TOPn;
  1870.       IV iv;
  1871.  
  1872.       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
  1873.       (iv = SvIVX(TOPs)) != IV_MIN) {
  1874.     if (iv < 0)
  1875.       iv = -iv;
  1876.     SETi(iv);
  1877.       }
  1878.       else {
  1879.     if (value < 0.0)
  1880.         value = -value;
  1881.     SETn(value);
  1882.       }
  1883.     }
  1884.     RETURN;
  1885. }
  1886.  
  1887. PP(pp_hex)
  1888. {
  1889.     djSP; dTARGET;
  1890.     char *tmps;
  1891.     I32 argtype;
  1892.     STRLEN n_a;
  1893.  
  1894.     tmps = POPpx;
  1895.     XPUSHn(scan_hex(tmps, 99, &argtype));
  1896.     RETURN;
  1897. }
  1898.  
  1899. PP(pp_oct)
  1900. {
  1901.     djSP; dTARGET;
  1902.     NV value;
  1903.     I32 argtype;
  1904.     char *tmps;
  1905.     STRLEN n_a;
  1906.  
  1907.     tmps = POPpx;
  1908.     while (*tmps && isSPACE(*tmps))
  1909.     tmps++;
  1910.     if (*tmps == '0')
  1911.     tmps++;
  1912.     if (*tmps == 'x')
  1913.     value = scan_hex(++tmps, 99, &argtype);
  1914.     else if (*tmps == 'b')
  1915.     value = scan_bin(++tmps, 99, &argtype);
  1916.     else
  1917.     value = scan_oct(tmps, 99, &argtype);
  1918.     XPUSHn(value);
  1919.     RETURN;
  1920. }
  1921.  
  1922. /* String stuff. */
  1923.  
  1924. PP(pp_length)
  1925. {
  1926.     djSP; dTARGET;
  1927.     SV *sv = TOPs;
  1928.  
  1929.     if (DO_UTF8(sv))
  1930.     SETi(sv_len_utf8(sv));
  1931.     else
  1932.     SETi(sv_len(sv));
  1933.     RETURN;
  1934. }
  1935.  
  1936. PP(pp_substr)
  1937. {
  1938.     djSP; dTARGET;
  1939.     SV *sv;
  1940.     I32 len;
  1941.     STRLEN curlen;
  1942.     STRLEN utfcurlen;
  1943.     I32 pos;
  1944.     I32 rem;
  1945.     I32 fail;
  1946.     I32 lvalue = PL_op->op_flags & OPf_MOD;
  1947.     char *tmps;
  1948.     I32 arybase = PL_curcop->cop_arybase;
  1949.     char *repl = 0;
  1950.     STRLEN repl_len;
  1951.  
  1952.     SvTAINTED_off(TARG);            /* decontaminate */
  1953.     SvUTF8_off(TARG);                /* decontaminate */
  1954.     if (MAXARG > 2) {
  1955.     if (MAXARG > 3) {
  1956.         sv = POPs;
  1957.         repl = SvPV(sv, repl_len);
  1958.     }
  1959.     len = POPi;
  1960.     }
  1961.     pos = POPi;
  1962.     sv = POPs;
  1963.     PUTBACK;
  1964.     tmps = SvPV(sv, curlen);
  1965.     if (DO_UTF8(sv)) {
  1966.         utfcurlen = sv_len_utf8(sv);
  1967.     if (utfcurlen == curlen)
  1968.         utfcurlen = 0;
  1969.     else
  1970.         curlen = utfcurlen;
  1971.     }
  1972.     else
  1973.     utfcurlen = 0;
  1974.  
  1975.     if (pos >= arybase) {
  1976.     pos -= arybase;
  1977.     rem = curlen-pos;
  1978.     fail = rem;
  1979.     if (MAXARG > 2) {
  1980.         if (len < 0) {
  1981.         rem += len;
  1982.         if (rem < 0)
  1983.             rem = 0;
  1984.         }
  1985.         else if (rem > len)
  1986.              rem = len;
  1987.     }
  1988.     }
  1989.     else {
  1990.     pos += curlen;
  1991.     if (MAXARG < 3)
  1992.         rem = curlen;
  1993.     else if (len >= 0) {
  1994.         rem = pos+len;
  1995.         if (rem > (I32)curlen)
  1996.         rem = curlen;
  1997.     }
  1998.     else {
  1999.         rem = curlen+len;
  2000.         if (rem < pos)
  2001.         rem = pos;
  2002.     }
  2003.     if (pos < 0)
  2004.         pos = 0;
  2005.     fail = rem;
  2006.     rem -= pos;
  2007.     }
  2008.     if (fail < 0) {
  2009.     if (lvalue || repl)
  2010.         Perl_croak(aTHX_ "substr outside of string");
  2011.     if (ckWARN(WARN_SUBSTR))
  2012.         Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
  2013.     RETPUSHUNDEF;
  2014.     }
  2015.     else {
  2016.         if (utfcurlen) {
  2017.         sv_pos_u2b(sv, &pos, &rem);
  2018.         SvUTF8_on(TARG);
  2019.     }
  2020.     tmps += pos;
  2021.     sv_setpvn(TARG, tmps, rem);
  2022.     if (repl)
  2023.         sv_insert(sv, pos, rem, repl, repl_len);
  2024.     else if (lvalue) {        /* it's an lvalue! */
  2025.         if (!SvGMAGICAL(sv)) {
  2026.         if (SvROK(sv)) {
  2027.             STRLEN n_a;
  2028.             SvPV_force(sv,n_a);
  2029.             if (ckWARN(WARN_SUBSTR))
  2030.             Perl_warner(aTHX_ WARN_SUBSTR,
  2031.                 "Attempt to use reference as lvalue in substr");
  2032.         }
  2033.         if (SvOK(sv))        /* is it defined ? */
  2034.             (void)SvPOK_only(sv);
  2035.         else
  2036.             sv_setpvn(sv,"",0);    /* avoid lexical reincarnation */
  2037.         }
  2038.  
  2039.         if (SvTYPE(TARG) < SVt_PVLV) {
  2040.         sv_upgrade(TARG, SVt_PVLV);
  2041.         sv_magic(TARG, Nullsv, 'x', Nullch, 0);
  2042.         }
  2043.  
  2044.         LvTYPE(TARG) = 'x';
  2045.         if (LvTARG(TARG) != sv) {
  2046.         if (LvTARG(TARG))
  2047.             SvREFCNT_dec(LvTARG(TARG));
  2048.         LvTARG(TARG) = SvREFCNT_inc(sv);
  2049.         }
  2050.         LvTARGOFF(TARG) = pos;
  2051.         LvTARGLEN(TARG) = rem;
  2052.     }
  2053.     }
  2054.     SPAGAIN;
  2055.     PUSHs(TARG);        /* avoid SvSETMAGIC here */
  2056.     RETURN;
  2057. }
  2058.  
  2059. PP(pp_vec)
  2060. {
  2061.     djSP; dTARGET;
  2062.     register I32 size = POPi;
  2063.     register I32 offset = POPi;
  2064.     register SV *src = POPs;
  2065.     I32 lvalue = PL_op->op_flags & OPf_MOD;
  2066.  
  2067.     SvTAINTED_off(TARG);        /* decontaminate */
  2068.     if (lvalue) {            /* it's an lvalue! */
  2069.     if (SvTYPE(TARG) < SVt_PVLV) {
  2070.         sv_upgrade(TARG, SVt_PVLV);
  2071.         sv_magic(TARG, Nullsv, 'v', Nullch, 0);
  2072.     }
  2073.     LvTYPE(TARG) = 'v';
  2074.     if (LvTARG(TARG) != src) {
  2075.         if (LvTARG(TARG))
  2076.         SvREFCNT_dec(LvTARG(TARG));
  2077.         LvTARG(TARG) = SvREFCNT_inc(src);
  2078.     }
  2079.     LvTARGOFF(TARG) = offset;
  2080.     LvTARGLEN(TARG) = size;
  2081.     }
  2082.  
  2083.     sv_setuv(TARG, do_vecget(src, offset, size));
  2084.     PUSHs(TARG);
  2085.     RETURN;
  2086. }
  2087.  
  2088. PP(pp_index)
  2089. {
  2090.     djSP; dTARGET;
  2091.     SV *big;
  2092.     SV *little;
  2093.     I32 offset;
  2094.     I32 retval;
  2095.     char *tmps;
  2096.     char *tmps2;
  2097.     STRLEN biglen;
  2098.     I32 arybase = PL_curcop->cop_arybase;
  2099.  
  2100.     if (MAXARG < 3)
  2101.     offset = 0;
  2102.     else
  2103.     offset = POPi - arybase;
  2104.     little = POPs;
  2105.     big = POPs;
  2106.     tmps = SvPV(big, biglen);
  2107.     if (offset > 0 && DO_UTF8(big))
  2108.     sv_pos_u2b(big, &offset, 0);
  2109.     if (offset < 0)
  2110.     offset = 0;
  2111.     else if (offset > biglen)
  2112.     offset = biglen;
  2113.     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
  2114.       (unsigned char*)tmps + biglen, little, 0)))
  2115.     retval = -1;
  2116.     else
  2117.     retval = tmps2 - tmps;
  2118.     if (retval > 0 && DO_UTF8(big))
  2119.     sv_pos_b2u(big, &retval);
  2120.     PUSHi(retval + arybase);
  2121.     RETURN;
  2122. }
  2123.  
  2124. PP(pp_rindex)
  2125. {
  2126.     djSP; dTARGET;
  2127.     SV *big;
  2128.     SV *little;
  2129.     STRLEN blen;
  2130.     STRLEN llen;
  2131.     I32 offset;
  2132.     I32 retval;
  2133.     char *tmps;
  2134.     char *tmps2;
  2135.     I32 arybase = PL_curcop->cop_arybase;
  2136.  
  2137.     if (MAXARG >= 3)
  2138.     offset = POPi;
  2139.     little = POPs;
  2140.     big = POPs;
  2141.     tmps2 = SvPV(little, llen);
  2142.     tmps = SvPV(big, blen);
  2143.     if (MAXARG < 3)
  2144.     offset = blen;
  2145.     else {
  2146.     if (offset > 0 && DO_UTF8(big))
  2147.         sv_pos_u2b(big, &offset, 0);
  2148.     offset = offset - arybase + llen;
  2149.     }
  2150.     if (offset < 0)
  2151.     offset = 0;
  2152.     else if (offset > blen)
  2153.     offset = blen;
  2154.     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
  2155.               tmps2, tmps2 + llen)))
  2156.     retval = -1;
  2157.     else
  2158.     retval = tmps2 - tmps;
  2159.     if (retval > 0 && DO_UTF8(big))
  2160.     sv_pos_b2u(big, &retval);
  2161.     PUSHi(retval + arybase);
  2162.     RETURN;
  2163. }
  2164.  
  2165. PP(pp_sprintf)
  2166. {
  2167.     djSP; dMARK; dORIGMARK; dTARGET;
  2168.     do_sprintf(TARG, SP-MARK, MARK+1);
  2169.     TAINT_IF(SvTAINTED(TARG));
  2170.     SP = ORIGMARK;
  2171.     PUSHTARG;
  2172.     RETURN;
  2173. }
  2174.  
  2175. PP(pp_ord)
  2176. {
  2177.     djSP; dTARGET;
  2178.     UV value;
  2179.     STRLEN n_a;
  2180.     SV *tmpsv = POPs;
  2181.     U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
  2182.     I32 retlen;
  2183.  
  2184.     if ((*tmps & 0x80) && DO_UTF8(tmpsv))
  2185.     value = utf8_to_uv(tmps, &retlen);
  2186.     else
  2187.     value = (UV)(*tmps & 255);
  2188.     XPUSHu(value);
  2189.     RETURN;
  2190. }
  2191.  
  2192. PP(pp_chr)
  2193. {
  2194.     djSP; dTARGET;
  2195.     char *tmps;
  2196.     U32 value = POPu;
  2197.  
  2198.     (void)SvUPGRADE(TARG,SVt_PV);
  2199.  
  2200.     if (value > 255 && !IN_BYTE) {
  2201.     SvGROW(TARG, UTF8_MAXLEN+1);
  2202.     tmps = SvPVX(TARG);
  2203.     tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
  2204.     SvCUR_set(TARG, tmps - SvPVX(TARG));
  2205.     *tmps = '\0';
  2206.     (void)SvPOK_only(TARG);
  2207.     SvUTF8_on(TARG);
  2208.     XPUSHs(TARG);
  2209.     RETURN;
  2210.     }
  2211.  
  2212.     SvGROW(TARG,2);
  2213.     SvCUR_set(TARG, 1);
  2214.     tmps = SvPVX(TARG);
  2215.     *tmps++ = value;
  2216.     *tmps = '\0';
  2217.     SvUTF8_off(TARG);                /* decontaminate */
  2218.     (void)SvPOK_only(TARG);
  2219.     XPUSHs(TARG);
  2220.     RETURN;
  2221. }
  2222.  
  2223. PP(pp_crypt)
  2224. {
  2225.     djSP; dTARGET; dPOPTOPssrl;
  2226.     STRLEN n_a;
  2227. #ifdef HAS_CRYPT
  2228.     char *tmps = SvPV(left, n_a);
  2229. #ifdef FCRYPT
  2230.     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
  2231. #else
  2232.     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
  2233. #endif
  2234. #else
  2235.     DIE(aTHX_ 
  2236.       "The crypt() function is unimplemented due to excessive paranoia.");
  2237. #endif
  2238.     SETs(TARG);
  2239.     RETURN;
  2240. }
  2241.  
  2242. PP(pp_ucfirst)
  2243. {
  2244.     djSP;
  2245.     SV *sv = TOPs;
  2246.     register U8 *s;
  2247.     STRLEN slen;
  2248.  
  2249.     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
  2250.     I32 ulen;
  2251.     U8 tmpbuf[UTF8_MAXLEN];
  2252.     U8 *tend;
  2253.     UV uv = utf8_to_uv(s, &ulen);
  2254.  
  2255.     if (PL_op->op_private & OPpLOCALE) {
  2256.         TAINT;
  2257.         SvTAINTED_on(sv);
  2258.         uv = toTITLE_LC_uni(uv);
  2259.     }
  2260.     else
  2261.         uv = toTITLE_utf8(s);
  2262.     
  2263.     tend = uv_to_utf8(tmpbuf, uv);
  2264.  
  2265.     if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
  2266.         dTARGET;
  2267.         sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
  2268.         sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
  2269.         SvUTF8_on(TARG);
  2270.         SETs(TARG);
  2271.     }
  2272.     else {
  2273.         s = (U8*)SvPV_force(sv, slen);
  2274.         Copy(tmpbuf, s, ulen, U8);
  2275.     }
  2276.     }
  2277.     else {
  2278.     if (!SvPADTMP(sv) || SvREADONLY(sv)) {
  2279.         dTARGET;
  2280.         SvUTF8_off(TARG);                /* decontaminate */
  2281.         sv_setsv(TARG, sv);
  2282.         sv = TARG;
  2283.         SETs(sv);
  2284.     }
  2285.     s = (U8*)SvPV_force(sv, slen);
  2286.     if (*s) {
  2287.         if (PL_op->op_private & OPpLOCALE) {
  2288.         TAINT;
  2289.         SvTAINTED_on(sv);
  2290.         *s = toUPPER_LC(*s);
  2291.         }
  2292.         else
  2293.         *s = toUPPER(*s);
  2294.     }
  2295.     }
  2296.     if (SvSMAGICAL(sv))
  2297.     mg_set(sv);
  2298.     RETURN;
  2299. }
  2300.  
  2301. PP(pp_lcfirst)
  2302. {
  2303.     djSP;
  2304.     SV *sv = TOPs;
  2305.     register U8 *s;
  2306.     STRLEN slen;
  2307.  
  2308.     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
  2309.     I32 ulen;
  2310.     U8 tmpbuf[UTF8_MAXLEN];
  2311.     U8 *tend;
  2312.     UV uv = utf8_to_uv(s, &ulen);
  2313.  
  2314.     if (PL_op->op_private & OPpLOCALE) {
  2315.         TAINT;
  2316.         SvTAINTED_on(sv);
  2317.         uv = toLOWER_LC_uni(uv);
  2318.     }
  2319.     else
  2320.         uv = toLOWER_utf8(s);
  2321.     
  2322.     tend = uv_to_utf8(tmpbuf, uv);
  2323.  
  2324.     if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
  2325.         dTARGET;
  2326.         sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
  2327.         sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
  2328.         SvUTF8_on(TARG);
  2329.         SETs(TARG);
  2330.     }
  2331.     else {
  2332.         s = (U8*)SvPV_force(sv, slen);
  2333.         Copy(tmpbuf, s, ulen, U8);
  2334.     }
  2335.     }
  2336.     else {
  2337.     if (!SvPADTMP(sv) || SvREADONLY(sv)) {
  2338.         dTARGET;
  2339.         SvUTF8_off(TARG);                /* decontaminate */
  2340.         sv_setsv(TARG, sv);
  2341.         sv = TARG;
  2342.         SETs(sv);
  2343.     }
  2344.     s = (U8*)SvPV_force(sv, slen);
  2345.     if (*s) {
  2346.         if (PL_op->op_private & OPpLOCALE) {
  2347.         TAINT;
  2348.         SvTAINTED_on(sv);
  2349.         *s = toLOWER_LC(*s);
  2350.         }
  2351.         else
  2352.         *s = toLOWER(*s);
  2353.     }
  2354.     }
  2355.     if (SvSMAGICAL(sv))
  2356.     mg_set(sv);
  2357.     RETURN;
  2358. }
  2359.  
  2360. PP(pp_uc)
  2361. {
  2362.     djSP;
  2363.     SV *sv = TOPs;
  2364.     register U8 *s;
  2365.     STRLEN len;
  2366.  
  2367.     if (DO_UTF8(sv)) {
  2368.     dTARGET;
  2369.     I32 ulen;
  2370.     register U8 *d;
  2371.     U8 *send;
  2372.  
  2373.     s = (U8*)SvPV(sv,len);
  2374.     if (!len) {
  2375.         SvUTF8_off(TARG);                /* decontaminate */
  2376.         sv_setpvn(TARG, "", 0);
  2377.         SETs(TARG);
  2378.     }
  2379.     else {
  2380.         (void)SvUPGRADE(TARG, SVt_PV);
  2381.         SvGROW(TARG, (len * 2) + 1);
  2382.         (void)SvPOK_only(TARG);
  2383.         d = (U8*)SvPVX(TARG);
  2384.         send = s + len;
  2385.         if (PL_op->op_private & OPpLOCALE) {
  2386.         TAINT;
  2387.         SvTAINTED_on(TARG);
  2388.         while (s < send) {
  2389.             d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
  2390.             s += ulen;
  2391.         }
  2392.         }
  2393.         else {
  2394.         while (s < send) {
  2395.             d = uv_to_utf8(d, toUPPER_utf8( s ));
  2396.             s += UTF8SKIP(s);
  2397.         }
  2398.         }
  2399.         *d = '\0';
  2400.         SvUTF8_on(TARG);
  2401.         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
  2402.         SETs(TARG);
  2403.     }
  2404.     }
  2405.     else {
  2406.     if (!SvPADTMP(sv) || SvREADONLY(sv)) {
  2407.         dTARGET;
  2408.         SvUTF8_off(TARG);                /* decontaminate */
  2409.         sv_setsv(TARG, sv);
  2410.         sv = TARG;
  2411.         SETs(sv);
  2412.     }
  2413.     s = (U8*)SvPV_force(sv, len);
  2414.     if (len) {
  2415.         register U8 *send = s + len;
  2416.  
  2417.         if (PL_op->op_private & OPpLOCALE) {
  2418.         TAINT;
  2419.         SvTAINTED_on(sv);
  2420.         for (; s < send; s++)
  2421.             *s = toUPPER_LC(*s);
  2422.         }
  2423.         else {
  2424.         for (; s < send; s++)
  2425.             *s = toUPPER(*s);
  2426.         }
  2427.     }
  2428.     }
  2429.     if (SvSMAGICAL(sv))
  2430.     mg_set(sv);
  2431.     RETURN;
  2432. }
  2433.  
  2434. PP(pp_lc)
  2435. {
  2436.     djSP;
  2437.     SV *sv = TOPs;
  2438.     register U8 *s;
  2439.     STRLEN len;
  2440.  
  2441.     if (DO_UTF8(sv)) {
  2442.     dTARGET;
  2443.     I32 ulen;
  2444.     register U8 *d;
  2445.     U8 *send;
  2446.  
  2447.     s = (U8*)SvPV(sv,len);
  2448.     if (!len) {
  2449.         SvUTF8_off(TARG);                /* decontaminate */
  2450.         sv_setpvn(TARG, "", 0);
  2451.         SETs(TARG);
  2452.     }
  2453.     else {
  2454.         (void)SvUPGRADE(TARG, SVt_PV);
  2455.         SvGROW(TARG, (len * 2) + 1);
  2456.         (void)SvPOK_only(TARG);
  2457.         d = (U8*)SvPVX(TARG);
  2458.         send = s + len;
  2459.         if (PL_op->op_private & OPpLOCALE) {
  2460.         TAINT;
  2461.         SvTAINTED_on(TARG);
  2462.         while (s < send) {
  2463.             d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
  2464.             s += ulen;
  2465.         }
  2466.         }
  2467.         else {
  2468.         while (s < send) {
  2469.             d = uv_to_utf8(d, toLOWER_utf8(s));
  2470.             s += UTF8SKIP(s);
  2471.         }
  2472.         }
  2473.         *d = '\0';
  2474.         SvUTF8_on(TARG);
  2475.         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
  2476.         SETs(TARG);
  2477.     }
  2478.     }
  2479.     else {
  2480.     if (!SvPADTMP(sv) || SvREADONLY(sv)) {
  2481.         dTARGET;
  2482.         SvUTF8_off(TARG);                /* decontaminate */
  2483.         sv_setsv(TARG, sv);
  2484.         sv = TARG;
  2485.         SETs(sv);
  2486.     }
  2487.  
  2488.     s = (U8*)SvPV_force(sv, len);
  2489.     if (len) {
  2490.         register U8 *send = s + len;
  2491.  
  2492.         if (PL_op->op_private & OPpLOCALE) {
  2493.         TAINT;
  2494.         SvTAINTED_on(sv);
  2495.         for (; s < send; s++)
  2496.             *s = toLOWER_LC(*s);
  2497.         }
  2498.         else {
  2499.         for (; s < send; s++)
  2500.             *s = toLOWER(*s);
  2501.         }
  2502.     }
  2503.     }
  2504.     if (SvSMAGICAL(sv))
  2505.     mg_set(sv);
  2506.     RETURN;
  2507. }
  2508.  
  2509. PP(pp_quotemeta)
  2510. {
  2511.     djSP; dTARGET;
  2512.     SV *sv = TOPs;
  2513.     STRLEN len;
  2514.     register char *s = SvPV(sv,len);
  2515.     register char *d;
  2516.  
  2517.     SvUTF8_off(TARG);                /* decontaminate */
  2518.     if (len) {
  2519.     (void)SvUPGRADE(TARG, SVt_PV);
  2520.     SvGROW(TARG, (len * 2) + 1);
  2521.     d = SvPVX(TARG);
  2522.     if (DO_UTF8(sv)) {
  2523.         while (len) {
  2524.         if (*s & 0x80) {
  2525.             STRLEN ulen = UTF8SKIP(s);
  2526.             if (ulen > len)
  2527.             ulen = len;
  2528.             len -= ulen;
  2529.             while (ulen--)
  2530.             *d++ = *s++;
  2531.         }
  2532.         else {
  2533.             if (!isALNUM(*s))
  2534.             *d++ = '\\';
  2535.             *d++ = *s++;
  2536.             len--;
  2537.         }
  2538.         }
  2539.         SvUTF8_on(TARG);
  2540.     }
  2541.     else {
  2542.         while (len--) {
  2543.         if (!isALNUM(*s))
  2544.             *d++ = '\\';
  2545.         *d++ = *s++;
  2546.         }
  2547.     }
  2548.     *d = '\0';
  2549.     SvCUR_set(TARG, d - SvPVX(TARG));
  2550.     (void)SvPOK_only(TARG);
  2551.     }
  2552.     else
  2553.     sv_setpvn(TARG, s, len);
  2554.     SETs(TARG);
  2555.     if (SvSMAGICAL(TARG))
  2556.     mg_set(TARG);
  2557.     RETURN;
  2558. }
  2559.  
  2560. /* Arrays. */
  2561.  
  2562. PP(pp_aslice)
  2563. {
  2564.     djSP; dMARK; dORIGMARK;
  2565.     register SV** svp;
  2566.     register AV* av = (AV*)POPs;
  2567.     register I32 lval = PL_op->op_flags & OPf_MOD;
  2568.     I32 arybase = PL_curcop->cop_arybase;
  2569.     I32 elem;
  2570.  
  2571.     if (SvTYPE(av) == SVt_PVAV) {
  2572.     if (lval && PL_op->op_private & OPpLVAL_INTRO) {
  2573.         I32 max = -1;
  2574.         for (svp = MARK + 1; svp <= SP; svp++) {
  2575.         elem = SvIVx(*svp);
  2576.         if (elem > max)
  2577.             max = elem;
  2578.         }
  2579.         if (max > AvMAX(av))
  2580.         av_extend(av, max);
  2581.     }
  2582.     while (++MARK <= SP) {
  2583.         elem = SvIVx(*MARK);
  2584.  
  2585.         if (elem > 0)
  2586.         elem -= arybase;
  2587.         svp = av_fetch(av, elem, lval);
  2588.         if (lval) {
  2589.         if (!svp || *svp == &PL_sv_undef)
  2590.             DIE(aTHX_ PL_no_aelem, elem);
  2591.         if (PL_op->op_private & OPpLVAL_INTRO)
  2592.             save_aelem(av, elem, svp);
  2593.         }
  2594.         *MARK = svp ? *svp : &PL_sv_undef;
  2595.     }
  2596.     }
  2597.     if (GIMME != G_ARRAY) {
  2598.     MARK = ORIGMARK;
  2599.     *++MARK = *SP;
  2600.     SP = MARK;
  2601.     }
  2602.     RETURN;
  2603. }
  2604.  
  2605. /* Associative arrays. */
  2606.  
  2607. PP(pp_each)
  2608. {
  2609.     djSP;
  2610.     HV *hash = (HV*)POPs;
  2611.     HE *entry;
  2612.     I32 gimme = GIMME_V;
  2613.     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
  2614.  
  2615.     PUTBACK;
  2616.     /* might clobber stack_sp */
  2617.     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
  2618.     SPAGAIN;
  2619.  
  2620.     EXTEND(SP, 2);
  2621.     if (entry) {
  2622.     PUSHs(hv_iterkeysv(entry));    /* won't clobber stack_sp */
  2623.     if (gimme == G_ARRAY) {
  2624.         SV *val;
  2625.         PUTBACK;
  2626.         /* might clobber stack_sp */
  2627.         val = realhv ?
  2628.           hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
  2629.         SPAGAIN;
  2630.         PUSHs(val);
  2631.     }
  2632.     }
  2633.     else if (gimme == G_SCALAR)
  2634.     RETPUSHUNDEF;
  2635.  
  2636.     RETURN;
  2637. }
  2638.  
  2639. PP(pp_values)
  2640. {
  2641.     return do_kv();
  2642. }
  2643.  
  2644. PP(pp_keys)
  2645. {
  2646.     return do_kv();
  2647. }
  2648.  
  2649. PP(pp_delete)
  2650. {
  2651.     djSP;
  2652.     I32 gimme = GIMME_V;
  2653.     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
  2654.     SV *sv;
  2655.     HV *hv;
  2656.  
  2657.     if (PL_op->op_private & OPpSLICE) {
  2658.     dMARK; dORIGMARK;
  2659.     U32 hvtype;
  2660.     hv = (HV*)POPs;
  2661.     hvtype = SvTYPE(hv);
  2662.     if (hvtype == SVt_PVHV) {            /* hash element */
  2663.         while (++MARK <= SP) {
  2664.         sv = hv_delete_ent(hv, *MARK, discard, 0);
  2665.         *MARK = sv ? sv : &PL_sv_undef;
  2666.         }
  2667.     }
  2668.     else if (hvtype == SVt_PVAV) {
  2669.         if (PL_op->op_flags & OPf_SPECIAL) {    /* array element */
  2670.         while (++MARK <= SP) {
  2671.             sv = av_delete((AV*)hv, SvIV(*MARK), discard);
  2672.             *MARK = sv ? sv : &PL_sv_undef;
  2673.         }
  2674.         }
  2675.         else {                    /* pseudo-hash element */
  2676.         while (++MARK <= SP) {
  2677.             sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
  2678.             *MARK = sv ? sv : &PL_sv_undef;
  2679.         }
  2680.         }
  2681.     }
  2682.     else
  2683.         DIE(aTHX_ "Not a HASH reference");
  2684.     if (discard)
  2685.         SP = ORIGMARK;
  2686.     else if (gimme == G_SCALAR) {
  2687.         MARK = ORIGMARK;
  2688.         *++MARK = *SP;
  2689.         SP = MARK;
  2690.     }
  2691.     }
  2692.     else {
  2693.     SV *keysv = POPs;
  2694.     hv = (HV*)POPs;
  2695.     if (SvTYPE(hv) == SVt_PVHV)
  2696.         sv = hv_delete_ent(hv, keysv, discard, 0);
  2697.     else if (SvTYPE(hv) == SVt_PVAV) {
  2698.         if (PL_op->op_flags & OPf_SPECIAL)
  2699.         sv = av_delete((AV*)hv, SvIV(keysv), discard);
  2700.         else
  2701.         sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
  2702.     }
  2703.     else
  2704.         DIE(aTHX_ "Not a HASH reference");
  2705.     if (!sv)
  2706.         sv = &PL_sv_undef;
  2707.     if (!discard)
  2708.         PUSHs(sv);
  2709.     }
  2710.     RETURN;
  2711. }
  2712.  
  2713. PP(pp_exists)
  2714. {
  2715.     djSP;
  2716.     SV *tmpsv;
  2717.     HV *hv;
  2718.  
  2719.     if (PL_op->op_private & OPpEXISTS_SUB) {
  2720.     GV *gv;
  2721.     CV *cv;
  2722.     SV *sv = POPs;
  2723.     cv = sv_2cv(sv, &hv, &gv, FALSE);
  2724.     if (cv)
  2725.         RETPUSHYES;
  2726.     if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
  2727.         RETPUSHYES;
  2728.     RETPUSHNO;
  2729.     }
  2730.     tmpsv = POPs;
  2731.     hv = (HV*)POPs;
  2732.     if (SvTYPE(hv) == SVt_PVHV) {
  2733.     if (hv_exists_ent(hv, tmpsv, 0))
  2734.         RETPUSHYES;
  2735.     }
  2736.     else if (SvTYPE(hv) == SVt_PVAV) {
  2737.     if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
  2738.         if (av_exists((AV*)hv, SvIV(tmpsv)))
  2739.         RETPUSHYES;
  2740.     }
  2741.     else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
  2742.         RETPUSHYES;
  2743.     }
  2744.     else {
  2745.     DIE(aTHX_ "Not a HASH reference");
  2746.     }
  2747.     RETPUSHNO;
  2748. }
  2749.  
  2750. PP(pp_hslice)
  2751. {
  2752.     djSP; dMARK; dORIGMARK;
  2753.     register HV *hv = (HV*)POPs;
  2754.     register I32 lval = PL_op->op_flags & OPf_MOD;
  2755.     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
  2756.  
  2757.     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
  2758.     DIE(aTHX_ "Can't localize pseudo-hash element");
  2759.  
  2760.     if (realhv || SvTYPE(hv) == SVt_PVAV) {
  2761.     while (++MARK <= SP) {
  2762.         SV *keysv = *MARK;
  2763.         SV **svp;
  2764.         if (realhv) {
  2765.         HE *he = hv_fetch_ent(hv, keysv, lval, 0);
  2766.         svp = he ? &HeVAL(he) : 0;
  2767.         }
  2768.         else {
  2769.         svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
  2770.         }
  2771.         if (lval) {
  2772.         if (!svp || *svp == &PL_sv_undef) {
  2773.             STRLEN n_a;
  2774.             DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
  2775.         }
  2776.         if (PL_op->op_private & OPpLVAL_INTRO)
  2777.             save_helem(hv, keysv, svp);
  2778.         }
  2779.         *MARK = svp ? *svp : &PL_sv_undef;
  2780.     }
  2781.     }
  2782.     if (GIMME != G_ARRAY) {
  2783.     MARK = ORIGMARK;
  2784.     *++MARK = *SP;
  2785.     SP = MARK;
  2786.     }
  2787.     RETURN;
  2788. }
  2789.  
  2790. /* List operators. */
  2791.  
  2792. PP(pp_list)
  2793. {
  2794.     djSP; dMARK;
  2795.     if (GIMME != G_ARRAY) {
  2796.     if (++MARK <= SP)
  2797.         *MARK = *SP;        /* unwanted list, return last item */
  2798.     else
  2799.         *MARK = &PL_sv_undef;
  2800.     SP = MARK;
  2801.     }
  2802.     RETURN;
  2803. }
  2804.  
  2805. PP(pp_lslice)
  2806. {
  2807.     djSP;
  2808.     SV **lastrelem = PL_stack_sp;
  2809.     SV **lastlelem = PL_stack_base + POPMARK;
  2810.     SV **firstlelem = PL_stack_base + POPMARK + 1;
  2811.     register SV **firstrelem = lastlelem + 1;
  2812.     I32 arybase = PL_curcop->cop_arybase;
  2813.     I32 lval = PL_op->op_flags & OPf_MOD;
  2814.     I32 is_something_there = lval;
  2815.  
  2816.     register I32 max = lastrelem - lastlelem;
  2817.     register SV **lelem;
  2818.     register I32 ix;
  2819.  
  2820.     if (GIMME != G_ARRAY) {
  2821.     ix = SvIVx(*lastlelem);
  2822.     if (ix < 0)
  2823.         ix += max;
  2824.     else
  2825.         ix -= arybase;
  2826.     if (ix < 0 || ix >= max)
  2827.         *firstlelem = &PL_sv_undef;
  2828.     else
  2829.         *firstlelem = firstrelem[ix];
  2830.     SP = firstlelem;
  2831.     RETURN;
  2832.     }
  2833.  
  2834.     if (max == 0) {
  2835.     SP = firstlelem - 1;
  2836.     RETURN;
  2837.     }
  2838.  
  2839.     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
  2840.     ix = SvIVx(*lelem);
  2841.     if (ix < 0)
  2842.         ix += max;
  2843.     else 
  2844.         ix -= arybase;
  2845.     if (ix < 0 || ix >= max)
  2846.         *lelem = &PL_sv_undef;
  2847.     else {
  2848.         is_something_there = TRUE;
  2849.         if (!(*lelem = firstrelem[ix]))
  2850.         *lelem = &PL_sv_undef;
  2851.     }
  2852.     }
  2853.     if (is_something_there)
  2854.     SP = lastlelem;
  2855.     else
  2856.     SP = firstlelem - 1;
  2857.     RETURN;
  2858. }
  2859.  
  2860. PP(pp_anonlist)
  2861. {
  2862.     djSP; dMARK; dORIGMARK;
  2863.     I32 items = SP - MARK;
  2864.     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
  2865.     SP = ORIGMARK;        /* av_make() might realloc stack_sp */
  2866.     XPUSHs(av);
  2867.     RETURN;
  2868. }
  2869.  
  2870. PP(pp_anonhash)
  2871. {
  2872.     djSP; dMARK; dORIGMARK;
  2873.     HV* hv = (HV*)sv_2mortal((SV*)newHV());
  2874.  
  2875.     while (MARK < SP) {
  2876.     SV* key = *++MARK;
  2877.     SV *val = NEWSV(46, 0);
  2878.     if (MARK < SP)
  2879.         sv_setsv(val, *++MARK);
  2880.     else if (ckWARN(WARN_MISC))
  2881.         Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
  2882.     (void)hv_store_ent(hv,key,val,0);
  2883.     }
  2884.     SP = ORIGMARK;
  2885.     XPUSHs((SV*)hv);
  2886.     RETURN;
  2887. }
  2888.  
  2889. PP(pp_splice)
  2890. {
  2891.     djSP; dMARK; dORIGMARK;
  2892.     register AV *ary = (AV*)*++MARK;
  2893.     register SV **src;
  2894.     register SV **dst;
  2895.     register I32 i;
  2896.     register I32 offset;
  2897.     register I32 length;
  2898.     I32 newlen;
  2899.     I32 after;
  2900.     I32 diff;
  2901.     SV **tmparyval = 0;
  2902.     MAGIC *mg;
  2903.  
  2904.     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
  2905.     *MARK-- = SvTIED_obj((SV*)ary, mg);
  2906.     PUSHMARK(MARK);
  2907.     PUTBACK;
  2908.     ENTER;
  2909.     call_method("SPLICE",GIMME_V);
  2910.     LEAVE;
  2911.     SPAGAIN;
  2912.     RETURN;
  2913.     }
  2914.  
  2915.     SP++;
  2916.  
  2917.     if (++MARK < SP) {
  2918.     offset = i = SvIVx(*MARK);
  2919.     if (offset < 0)
  2920.         offset += AvFILLp(ary) + 1;
  2921.     else
  2922.         offset -= PL_curcop->cop_arybase;
  2923.     if (offset < 0)
  2924.         DIE(aTHX_ PL_no_aelem, i);
  2925.     if (++MARK < SP) {
  2926.         length = SvIVx(*MARK++);
  2927.         if (length < 0) {
  2928.         length += AvFILLp(ary) - offset + 1;
  2929.         if (length < 0)
  2930.             length = 0;
  2931.         }
  2932.     }
  2933.     else
  2934.         length = AvMAX(ary) + 1;        /* close enough to infinity */
  2935.     }
  2936.     else {
  2937.     offset = 0;
  2938.     length = AvMAX(ary) + 1;
  2939.     }
  2940.     if (offset > AvFILLp(ary) + 1)
  2941.     offset = AvFILLp(ary) + 1;
  2942.     after = AvFILLp(ary) + 1 - (offset + length);
  2943.     if (after < 0) {                /* not that much array */
  2944.     length += after;            /* offset+length now in array */
  2945.     after = 0;
  2946.     if (!AvALLOC(ary))
  2947.         av_extend(ary, 0);
  2948.     }
  2949.  
  2950.     /* At this point, MARK .. SP-1 is our new LIST */
  2951.  
  2952.     newlen = SP - MARK;
  2953.     diff = newlen - length;
  2954.     if (newlen && !AvREAL(ary) && AvREIFY(ary))
  2955.     av_reify(ary);
  2956.  
  2957.     if (diff < 0) {                /* shrinking the area */
  2958.     if (newlen) {
  2959.         New(451, tmparyval, newlen, SV*);    /* so remember insertion */
  2960.         Copy(MARK, tmparyval, newlen, SV*);
  2961.     }
  2962.  
  2963.     MARK = ORIGMARK + 1;
  2964.     if (GIMME == G_ARRAY) {            /* copy return vals to stack */
  2965.         MEXTEND(MARK, length);
  2966.         Copy(AvARRAY(ary)+offset, MARK, length, SV*);
  2967.         if (AvREAL(ary)) {
  2968.         EXTEND_MORTAL(length);
  2969.         for (i = length, dst = MARK; i; i--) {
  2970.             sv_2mortal(*dst);    /* free them eventualy */
  2971.             dst++;
  2972.         }
  2973.         }
  2974.         MARK += length - 1;
  2975.     }
  2976.     else {
  2977.         *MARK = AvARRAY(ary)[offset+length-1];
  2978.         if (AvREAL(ary)) {
  2979.         sv_2mortal(*MARK);
  2980.         for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
  2981.             SvREFCNT_dec(*dst++);    /* free them now */
  2982.         }
  2983.     }
  2984.     AvFILLp(ary) += diff;
  2985.  
  2986.     /* pull up or down? */
  2987.  
  2988.     if (offset < after) {            /* easier to pull up */
  2989.         if (offset) {            /* esp. if nothing to pull */
  2990.         src = &AvARRAY(ary)[offset-1];
  2991.         dst = src - diff;        /* diff is negative */
  2992.         for (i = offset; i > 0; i--)    /* can't trust Copy */
  2993.             *dst-- = *src--;
  2994.         }
  2995.         dst = AvARRAY(ary);
  2996.         SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
  2997.         AvMAX(ary) += diff;
  2998.     }
  2999.     else {
  3000.         if (after) {            /* anything to pull down? */
  3001.         src = AvARRAY(ary) + offset + length;
  3002.         dst = src + diff;        /* diff is negative */
  3003.         Move(src, dst, after, SV*);
  3004.         }
  3005.         dst = &AvARRAY(ary)[AvFILLp(ary)+1];
  3006.                         /* avoid later double free */
  3007.     }
  3008.     i = -diff;
  3009.     while (i)
  3010.         dst[--i] = &PL_sv_undef;
  3011.     
  3012.     if (newlen) {
  3013.         for (src = tmparyval, dst = AvARRAY(ary) + offset;
  3014.           newlen; newlen--) {
  3015.         *dst = NEWSV(46, 0);
  3016.         sv_setsv(*dst++, *src++);
  3017.         }
  3018.         Safefree(tmparyval);
  3019.     }
  3020.     }
  3021.     else {                    /* no, expanding (or same) */
  3022.     if (length) {
  3023.         New(452, tmparyval, length, SV*);    /* so remember deletion */
  3024.         Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
  3025.     }
  3026.  
  3027.     if (diff > 0) {                /* expanding */
  3028.  
  3029.         /* push up or down? */
  3030.  
  3031.         if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
  3032.         if (offset) {
  3033.             src = AvARRAY(ary);
  3034.             dst = src - diff;
  3035.             Move(src, dst, offset, SV*);
  3036.         }
  3037.         SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
  3038.         AvMAX(ary) += diff;
  3039.         AvFILLp(ary) += diff;
  3040.         }
  3041.         else {
  3042.         if (AvFILLp(ary) + diff >= AvMAX(ary))    /* oh, well */
  3043.             av_extend(ary, AvFILLp(ary) + diff);
  3044.         AvFILLp(ary) += diff;
  3045.  
  3046.         if (after) {
  3047.             dst = AvARRAY(ary) + AvFILLp(ary);
  3048.             src = dst - diff;
  3049.             for (i = after; i; i--) {
  3050.             *dst-- = *src--;
  3051.             }
  3052.         }
  3053.         }
  3054.     }
  3055.  
  3056.     for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
  3057.         *dst = NEWSV(46, 0);
  3058.         sv_setsv(*dst++, *src++);
  3059.     }
  3060.     MARK = ORIGMARK + 1;
  3061.     if (GIMME == G_ARRAY) {            /* copy return vals to stack */
  3062.         if (length) {
  3063.         Copy(tmparyval, MARK, length, SV*);
  3064.         if (AvREAL(ary)) {
  3065.             EXTEND_MORTAL(length);
  3066.             for (i = length, dst = MARK; i; i--) {
  3067.             sv_2mortal(*dst);    /* free them eventualy */
  3068.             dst++;
  3069.             }
  3070.         }
  3071.         Safefree(tmparyval);
  3072.         }
  3073.         MARK += length - 1;
  3074.     }
  3075.     else if (length--) {
  3076.         *MARK = tmparyval[length];
  3077.         if (AvREAL(ary)) {
  3078.         sv_2mortal(*MARK);
  3079.         while (length-- > 0)
  3080.             SvREFCNT_dec(tmparyval[length]);
  3081.         }
  3082.         Safefree(tmparyval);
  3083.     }
  3084.     else
  3085.         *MARK = &PL_sv_undef;
  3086.     }
  3087.     SP = MARK;
  3088.     RETURN;
  3089. }
  3090.  
  3091. PP(pp_push)
  3092. {
  3093.     djSP; dMARK; dORIGMARK; dTARGET;
  3094.     register AV *ary = (AV*)*++MARK;
  3095.     register SV *sv = &PL_sv_undef;
  3096.     MAGIC *mg;
  3097.  
  3098.     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
  3099.     *MARK-- = SvTIED_obj((SV*)ary, mg);
  3100.     PUSHMARK(MARK);
  3101.     PUTBACK;
  3102.     ENTER;
  3103.     call_method("PUSH",G_SCALAR|G_DISCARD);
  3104.     LEAVE;
  3105.     SPAGAIN;
  3106.     }
  3107.     else {
  3108.     /* Why no pre-extend of ary here ? */
  3109.     for (++MARK; MARK <= SP; MARK++) {
  3110.         sv = NEWSV(51, 0);
  3111.         if (*MARK)
  3112.         sv_setsv(sv, *MARK);
  3113.         av_push(ary, sv);
  3114.     }
  3115.     }
  3116.     SP = ORIGMARK;
  3117.     PUSHi( AvFILL(ary) + 1 );
  3118.     RETURN;
  3119. }
  3120.  
  3121. PP(pp_pop)
  3122. {
  3123.     djSP;
  3124.     AV *av = (AV*)POPs;
  3125.     SV *sv = av_pop(av);
  3126.     if (AvREAL(av))
  3127.     (void)sv_2mortal(sv);
  3128.     PUSHs(sv);
  3129.     RETURN;
  3130. }
  3131.  
  3132. PP(pp_shift)
  3133. {
  3134.     djSP;
  3135.     AV *av = (AV*)POPs;
  3136.     SV *sv = av_shift(av);
  3137.     EXTEND(SP, 1);
  3138.     if (!sv)
  3139.     RETPUSHUNDEF;
  3140.     if (AvREAL(av))
  3141.     (void)sv_2mortal(sv);
  3142.     PUSHs(sv);
  3143.     RETURN;
  3144. }
  3145.  
  3146. PP(pp_unshift)
  3147. {
  3148.     djSP; dMARK; dORIGMARK; dTARGET;
  3149.     register AV *ary = (AV*)*++MARK;
  3150.     register SV *sv;
  3151.     register I32 i = 0;
  3152.     MAGIC *mg;
  3153.  
  3154.     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
  3155.     *MARK-- = SvTIED_obj((SV*)ary, mg);
  3156.     PUSHMARK(MARK);
  3157.     PUTBACK;
  3158.     ENTER;
  3159.     call_method("UNSHIFT",G_SCALAR|G_DISCARD);
  3160.     LEAVE;
  3161.     SPAGAIN;
  3162.     }
  3163.     else {
  3164.     av_unshift(ary, SP - MARK);
  3165.     while (MARK < SP) {
  3166.         sv = NEWSV(27, 0);
  3167.         sv_setsv(sv, *++MARK);
  3168.         (void)av_store(ary, i++, sv);
  3169.     }
  3170.     }
  3171.     SP = ORIGMARK;
  3172.     PUSHi( AvFILL(ary) + 1 );
  3173.     RETURN;
  3174. }
  3175.  
  3176. PP(pp_reverse)
  3177. {
  3178.     djSP; dMARK;
  3179.     register SV *tmp;
  3180.     SV **oldsp = SP;
  3181.  
  3182.     if (GIMME == G_ARRAY) {
  3183.     MARK++;
  3184.     while (MARK < SP) {
  3185.         tmp = *MARK;
  3186.         *MARK++ = *SP;
  3187.         *SP-- = tmp;
  3188.     }
  3189.     /* safe as long as stack cannot get extended in the above */
  3190.     SP = oldsp;
  3191.     }
  3192.     else {
  3193.     register char *up;
  3194.     register char *down;
  3195.     register I32 tmp;
  3196.     dTARGET;
  3197.     STRLEN len;
  3198.  
  3199.     SvUTF8_off(TARG);                /* decontaminate */
  3200.     if (SP - MARK > 1)
  3201.         do_join(TARG, &PL_sv_no, MARK, SP);
  3202.     else
  3203.         sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
  3204.     up = SvPV_force(TARG, len);
  3205.     if (len > 1) {
  3206.         if (DO_UTF8(TARG)) {    /* first reverse each character */
  3207.         U8* s = (U8*)SvPVX(TARG);
  3208.         U8* send = (U8*)(s + len);
  3209.         while (s < send) {
  3210.             if (*s < 0x80) {
  3211.             s++;
  3212.             continue;
  3213.             }
  3214.             else {
  3215.             up = (char*)s;
  3216.             s += UTF8SKIP(s);
  3217.             down = (char*)(s - 1);
  3218.             if (s > send || !((*down & 0xc0) == 0x80)) {
  3219.                 if (ckWARN_d(WARN_UTF8))
  3220.                 Perl_warner(aTHX_ WARN_UTF8,
  3221.                         "Malformed UTF-8 character");
  3222.                 break;
  3223.             }
  3224.             while (down > up) {
  3225.                 tmp = *up;
  3226.                 *up++ = *down;
  3227.                 *down-- = tmp;
  3228.             }
  3229.             }
  3230.         }
  3231.         up = SvPVX(TARG);
  3232.         }
  3233.         down = SvPVX(TARG) + len - 1;
  3234.         while (down > up) {
  3235.         tmp = *up;
  3236.         *up++ = *down;
  3237.         *down-- = tmp;
  3238.         }
  3239.         (void)SvPOK_only(TARG);
  3240.     }
  3241.     SP = MARK + 1;
  3242.     SETTARG;
  3243.     }
  3244.     RETURN;
  3245. }
  3246.  
  3247. STATIC SV *
  3248. S_mul128(pTHX_ SV *sv, U8 m)
  3249. {
  3250.   STRLEN          len;
  3251.   char           *s = SvPV(sv, len);
  3252.   char           *t;
  3253.   U32             i = 0;
  3254.  
  3255.   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
  3256.     SV             *tmpNew = newSVpvn("0000000000", 10);
  3257.  
  3258.     sv_catsv(tmpNew, sv);
  3259.     SvREFCNT_dec(sv);        /* free old sv */
  3260.     sv = tmpNew;
  3261.     s = SvPV(sv, len);
  3262.   }
  3263.   t = s + len - 1;
  3264.   while (!*t)                   /* trailing '\0'? */
  3265.     t--;
  3266.   while (t > s) {
  3267.     i = ((*t - '0') << 7) + m;
  3268.     *(t--) = '0' + (i % 10);
  3269.     m = i / 10;
  3270.   }
  3271.   return (sv);
  3272. }
  3273.  
  3274. /* Explosives and implosives. */
  3275.  
  3276. #if 'I' == 73 && 'J' == 74
  3277. /* On an ASCII/ISO kind of system */
  3278. #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
  3279. #else
  3280. /*
  3281.   Some other sort of character set - use memchr() so we don't match
  3282.   the null byte.
  3283.  */
  3284. #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
  3285. #endif
  3286.  
  3287. PP(pp_unpack)
  3288. {
  3289.     djSP;
  3290.     dPOPPOPssrl;
  3291.     I32 start_sp_offset = SP - PL_stack_base;
  3292.     I32 gimme = GIMME_V;
  3293.     SV *sv;
  3294.     STRLEN llen;
  3295.     STRLEN rlen;
  3296.     register char *pat = SvPV(left, llen);
  3297.     register char *s = SvPV(right, rlen);
  3298.     char *strend = s + rlen;
  3299.     char *strbeg = s;
  3300.     register char *patend = pat + llen;
  3301.     I32 datumtype;
  3302.     register I32 len;
  3303.     register I32 bits;
  3304.     register char *str;
  3305.  
  3306.     /* These must not be in registers: */
  3307.     I16 ashort;
  3308.     int aint;
  3309.     I32 along;
  3310. #ifdef HAS_QUAD
  3311.     Quad_t aquad;
  3312. #endif
  3313.     U16 aushort;
  3314.     unsigned int auint;
  3315.     U32 aulong;
  3316. #ifdef HAS_QUAD
  3317.     Uquad_t auquad;
  3318. #endif
  3319.     char *aptr;
  3320.     float afloat;
  3321.     double adouble;
  3322.     I32 checksum = 0;
  3323.     register U32 culong;
  3324.     NV cdouble;
  3325.     int commas = 0;
  3326.     int star;
  3327. #ifdef PERL_NATINT_PACK
  3328.     int natint;        /* native integer */
  3329.     int unatint;    /* unsigned native integer */
  3330. #endif
  3331.  
  3332.     if (gimme != G_ARRAY) {        /* arrange to do first one only */
  3333.     /*SUPPRESS 530*/
  3334.     for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
  3335.     if (strchr("aAZbBhHP", *patend) || *pat == '%') {
  3336.         patend++;
  3337.         while (isDIGIT(*patend) || *patend == '*')
  3338.         patend++;
  3339.     }
  3340.     else
  3341.         patend++;
  3342.     }
  3343.     while (pat < patend) {
  3344.       reparse:
  3345.     datumtype = *pat++ & 0xFF;
  3346. #ifdef PERL_NATINT_PACK
  3347.     natint = 0;
  3348. #endif
  3349.     if (isSPACE(datumtype))
  3350.         continue;
  3351.     if (datumtype == '#') {
  3352.         while (pat < patend && *pat != '\n')
  3353.         pat++;
  3354.         continue;
  3355.     }
  3356.     if (*pat == '!') {
  3357.         char *natstr = "sSiIlL";
  3358.  
  3359.         if (strchr(natstr, datumtype)) {
  3360. #ifdef PERL_NATINT_PACK
  3361.         natint = 1;
  3362. #endif
  3363.         pat++;
  3364.         }
  3365.         else
  3366.         DIE(aTHX_ "'!' allowed only after types %s", natstr);
  3367.     }
  3368.     star = 0;
  3369.     if (pat >= patend)
  3370.         len = 1;
  3371.     else if (*pat == '*') {
  3372.         len = strend - strbeg;    /* long enough */
  3373.         pat++;
  3374.         star = 1;
  3375.     }
  3376.     else if (isDIGIT(*pat)) {
  3377.         len = *pat++ - '0';
  3378.         while (isDIGIT(*pat)) {
  3379.         len = (len * 10) + (*pat++ - '0');
  3380.         if (len < 0)
  3381.             DIE(aTHX_ "Repeat count in unpack overflows");
  3382.         }
  3383.     }
  3384.     else
  3385.         len = (datumtype != '@');
  3386.       redo_switch:
  3387.     switch(datumtype) {
  3388.     default:
  3389.         DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
  3390.     case ',': /* grandfather in commas but with a warning */
  3391.         if (commas++ == 0 && ckWARN(WARN_UNPACK))
  3392.         Perl_warner(aTHX_ WARN_UNPACK,
  3393.                 "Invalid type in unpack: '%c'", (int)datumtype);
  3394.         break;
  3395.     case '%':
  3396.         if (len == 1 && pat[-1] != '1')
  3397.         len = 16;
  3398.         checksum = len;
  3399.         culong = 0;
  3400.         cdouble = 0;
  3401.         if (pat < patend)
  3402.         goto reparse;
  3403.         break;
  3404.     case '@':
  3405.         if (len > strend - strbeg)
  3406.         DIE(aTHX_ "@ outside of string");
  3407.         s = strbeg + len;
  3408.         break;
  3409.     case 'X':
  3410.         if (len > s - strbeg)
  3411.         DIE(aTHX_ "X outside of string");
  3412.         s -= len;
  3413.         break;
  3414.     case 'x':
  3415.         if (len > strend - s)
  3416.         DIE(aTHX_ "x outside of string");
  3417.         s += len;
  3418.         break;
  3419.     case '/':
  3420.         if (start_sp_offset >= SP - PL_stack_base)
  3421.         DIE(aTHX_ "/ must follow a numeric type");
  3422.         datumtype = *pat++;
  3423.         if (*pat == '*')
  3424.         pat++;        /* ignore '*' for compatibility with pack */
  3425.         if (isDIGIT(*pat))
  3426.         DIE(aTHX_ "/ cannot take a count" );
  3427.         len = POPi;
  3428.         star = 0;
  3429.         goto redo_switch;
  3430.     case 'A':
  3431.     case 'Z':
  3432.     case 'a':
  3433.         if (len > strend - s)
  3434.         len = strend - s;
  3435.         if (checksum)
  3436.         goto uchar_checksum;
  3437.         sv = NEWSV(35, len);
  3438.         sv_setpvn(sv, s, len);
  3439.         s += len;
  3440.         if (datumtype == 'A' || datumtype == 'Z') {
  3441.         aptr = s;    /* borrow register */
  3442.         if (datumtype == 'Z') {    /* 'Z' strips stuff after first null */
  3443.             s = SvPVX(sv);
  3444.             while (*s)
  3445.             s++;
  3446.         }
  3447.         else {        /* 'A' strips both nulls and spaces */
  3448.             s = SvPVX(sv) + len - 1;
  3449.             while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
  3450.             s--;
  3451.             *++s = '\0';
  3452.         }
  3453.         SvCUR_set(sv, s - SvPVX(sv));
  3454.         s = aptr;    /* unborrow register */
  3455.         }
  3456.         XPUSHs(sv_2mortal(sv));
  3457.         break;
  3458.     case 'B':
  3459.     case 'b':
  3460.         if (star || len > (strend - s) * 8)
  3461.         len = (strend - s) * 8;
  3462.         if (checksum) {
  3463.         if (!PL_bitcount) {
  3464.             Newz(601, PL_bitcount, 256, char);
  3465.             for (bits = 1; bits < 256; bits++) {
  3466.             if (bits & 1)    PL_bitcount[bits]++;
  3467.             if (bits & 2)    PL_bitcount[bits]++;
  3468.             if (bits & 4)    PL_bitcount[bits]++;
  3469.             if (bits & 8)    PL_bitcount[bits]++;
  3470.             if (bits & 16)    PL_bitcount[bits]++;
  3471.             if (bits & 32)    PL_bitcount[bits]++;
  3472.             if (bits & 64)    PL_bitcount[bits]++;
  3473.             if (bits & 128)    PL_bitcount[bits]++;
  3474.             }
  3475.         }
  3476.         while (len >= 8) {
  3477.             culong += PL_bitcount[*(unsigned char*)s++];
  3478.             len -= 8;
  3479.         }
  3480.         if (len) {
  3481.             bits = *s;
  3482.             if (datumtype == 'b') {
  3483.             while (len-- > 0) {
  3484.                 if (bits & 1) culong++;
  3485.                 bits >>= 1;
  3486.             }
  3487.             }
  3488.             else {
  3489.             while (len-- > 0) {
  3490.                 if (bits & 128) culong++;
  3491.                 bits <<= 1;
  3492.             }
  3493.             }
  3494.         }
  3495.         break;
  3496.         }
  3497.         sv = NEWSV(35, len + 1);
  3498.         SvCUR_set(sv, len);
  3499.         SvPOK_on(sv);
  3500.         str = SvPVX(sv);
  3501.         if (datumtype == 'b') {
  3502.         aint = len;
  3503.         for (len = 0; len < aint; len++) {
  3504.             if (len & 7)        /*SUPPRESS 595*/
  3505.             bits >>= 1;
  3506.             else
  3507.             bits = *s++;
  3508.             *str++ = '0' + (bits & 1);
  3509.         }
  3510.         }
  3511.         else {
  3512.         aint = len;
  3513.         for (len = 0; len < aint; len++) {
  3514.             if (len & 7)
  3515.             bits <<= 1;
  3516.             else
  3517.             bits = *s++;
  3518.             *str++ = '0' + ((bits & 128) != 0);
  3519.         }
  3520.         }
  3521.         *str = '\0';
  3522.         XPUSHs(sv_2mortal(sv));
  3523.         break;
  3524.     case 'H':
  3525.     case 'h':
  3526.         if (star || len > (strend - s) * 2)
  3527.         len = (strend - s) * 2;
  3528.         sv = NEWSV(35, len + 1);
  3529.         SvCUR_set(sv, len);
  3530.         SvPOK_on(sv);
  3531.         str = SvPVX(sv);
  3532.         if (datumtype == 'h') {
  3533.         aint = len;
  3534.         for (len = 0; len < aint; len++) {
  3535.             if (len & 1)
  3536.             bits >>= 4;
  3537.             else
  3538.             bits = *s++;
  3539.             *str++ = PL_hexdigit[bits & 15];
  3540.         }
  3541.         }
  3542.         else {
  3543.         aint = len;
  3544.         for (len = 0; len < aint; len++) {
  3545.             if (len & 1)
  3546.             bits <<= 4;
  3547.             else
  3548.             bits = *s++;
  3549.             *str++ = PL_hexdigit[(bits >> 4) & 15];
  3550.         }
  3551.         }
  3552.         *str = '\0';
  3553.         XPUSHs(sv_2mortal(sv));
  3554.         break;
  3555.     case 'c':
  3556.         if (len > strend - s)
  3557.         len = strend - s;
  3558.         if (checksum) {
  3559.         while (len-- > 0) {
  3560.             aint = *s++;
  3561.             if (aint >= 128)    /* fake up signed chars */
  3562.             aint -= 256;
  3563.             culong += aint;
  3564.         }
  3565.         }
  3566.         else {
  3567.         EXTEND(SP, len);
  3568.         EXTEND_MORTAL(len);
  3569.         while (len-- > 0) {
  3570.             aint = *s++;
  3571.             if (aint >= 128)    /* fake up signed chars */
  3572.             aint -= 256;
  3573.             sv = NEWSV(36, 0);
  3574.             sv_setiv(sv, (IV)aint);
  3575.             PUSHs(sv_2mortal(sv));
  3576.         }
  3577.         }
  3578.         break;
  3579.     case 'C':
  3580.         if (len > strend - s)
  3581.         len = strend - s;
  3582.         if (checksum) {
  3583.           uchar_checksum:
  3584.         while (len-- > 0) {
  3585.             auint = *s++ & 255;
  3586.             culong += auint;
  3587.         }
  3588.         }
  3589.         else {
  3590.         EXTEND(SP, len);
  3591.         EXTEND_MORTAL(len);
  3592.         while (len-- > 0) {
  3593.             auint = *s++ & 255;
  3594.             sv = NEWSV(37, 0);
  3595.             sv_setiv(sv, (IV)auint);
  3596.             PUSHs(sv_2mortal(sv));
  3597.         }
  3598.         }
  3599.         break;
  3600.     case 'U':
  3601.         if (len > strend - s)
  3602.         len = strend - s;
  3603.         if (checksum) {
  3604.         while (len-- > 0 && s < strend) {
  3605.             auint = utf8_to_uv((U8*)s, &along);
  3606.             s += along;
  3607.             if (checksum > 32)
  3608.             cdouble += (NV)auint;
  3609.             else
  3610.             culong += auint;
  3611.         }
  3612.         }
  3613.         else {
  3614.         EXTEND(SP, len);
  3615.         EXTEND_MORTAL(len);
  3616.         while (len-- > 0 && s < strend) {
  3617.             auint = utf8_to_uv((U8*)s, &along);
  3618.             s += along;
  3619.             sv = NEWSV(37, 0);
  3620.             sv_setuv(sv, (UV)auint);
  3621.             PUSHs(sv_2mortal(sv));
  3622.         }
  3623.         }
  3624.         break;
  3625.     case 's':
  3626. #if SHORTSIZE == SIZE16
  3627.         along = (strend - s) / SIZE16;
  3628. #else
  3629.         along = (strend - s) / (natint ? sizeof(short) : SIZE16);
  3630. #endif
  3631.         if (len > along)
  3632.         len = along;
  3633.         if (checksum) {
  3634. #if SHORTSIZE != SIZE16
  3635.         if (natint) {
  3636.             short ashort;
  3637.             while (len-- > 0) {
  3638.             COPYNN(s, &ashort, sizeof(short));
  3639.             s += sizeof(short);
  3640.             culong += ashort;
  3641.  
  3642.             }
  3643.         }
  3644.         else
  3645. #endif
  3646.                 {
  3647.             while (len-- > 0) {
  3648.             COPY16(s, &ashort);
  3649. #if SHORTSIZE > SIZE16
  3650.             if (ashort > 32767)
  3651.               ashort -= 65536;
  3652. #endif
  3653.             s += SIZE16;
  3654.             culong += ashort;
  3655.             }
  3656.         }
  3657.         }
  3658.         else {
  3659.         EXTEND(SP, len);
  3660.         EXTEND_MORTAL(len);
  3661. #if SHORTSIZE != SIZE16
  3662.         if (natint) {
  3663.             short ashort;
  3664.             while (len-- > 0) {
  3665.             COPYNN(s, &ashort, sizeof(short));
  3666.             s += sizeof(short);
  3667.             sv = NEWSV(38, 0);
  3668.             sv_setiv(sv, (IV)ashort);
  3669.             PUSHs(sv_2mortal(sv));
  3670.             }
  3671.         }
  3672.         else
  3673. #endif
  3674.                 {
  3675.             while (len-- > 0) {
  3676.             COPY16(s, &ashort);
  3677. #if SHORTSIZE > SIZE16
  3678.             if (ashort > 32767)
  3679.               ashort -= 65536;
  3680. #endif
  3681.             s += SIZE16;
  3682.             sv = NEWSV(38, 0);
  3683.             sv_setiv(sv, (IV)ashort);
  3684.             PUSHs(sv_2mortal(sv));
  3685.             }
  3686.         }
  3687.         }
  3688.         break;
  3689.     case 'v':
  3690.     case 'n':
  3691.     case 'S':
  3692. #if SHORTSIZE == SIZE16
  3693.         along = (strend - s) / SIZE16;
  3694. #else
  3695.         unatint = natint && datumtype == 'S';
  3696.         along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
  3697. #endif
  3698.         if (len > along)
  3699.         len = along;
  3700.         if (checksum) {
  3701. #if SHORTSIZE != SIZE16
  3702.         if (unatint) {
  3703.             unsigned short aushort;
  3704.             while (len-- > 0) {
  3705.             COPYNN(s, &aushort, sizeof(unsigned short));
  3706.             s += sizeof(unsigned short);
  3707.             culong += aushort;
  3708.             }
  3709.         }
  3710.         else
  3711. #endif
  3712.                 {
  3713.             while (len-- > 0) {
  3714.             COPY16(s, &aushort);
  3715.             s += SIZE16;
  3716. #ifdef HAS_NTOHS
  3717.             if (datumtype == 'n')
  3718.                 aushort = PerlSock_ntohs(aushort);
  3719. #endif
  3720. #ifdef HAS_VTOHS
  3721.             if (datumtype == 'v')
  3722.                 aushort = vtohs(aushort);
  3723. #endif
  3724.             culong += aushort;
  3725.             }
  3726.         }
  3727.         }
  3728.         else {
  3729.         EXTEND(SP, len);
  3730.         EXTEND_MORTAL(len);
  3731. #if SHORTSIZE != SIZE16
  3732.         if (unatint) {
  3733.             unsigned short aushort;
  3734.             while (len-- > 0) {
  3735.             COPYNN(s, &aushort, sizeof(unsigned short));
  3736.             s += sizeof(unsigned short);
  3737.             sv = NEWSV(39, 0);
  3738.             sv_setiv(sv, (UV)aushort);
  3739.             PUSHs(sv_2mortal(sv));
  3740.             }
  3741.         }
  3742.         else
  3743. #endif
  3744.                 {
  3745.             while (len-- > 0) {
  3746.             COPY16(s, &aushort);
  3747.             s += SIZE16;
  3748.             sv = NEWSV(39, 0);
  3749. #ifdef HAS_NTOHS
  3750.             if (datumtype == 'n')
  3751.                 aushort = PerlSock_ntohs(aushort);
  3752. #endif
  3753. #ifdef HAS_VTOHS
  3754.             if (datumtype == 'v')
  3755.                 aushort = vtohs(aushort);
  3756. #endif
  3757.             sv_setiv(sv, (UV)aushort);
  3758.             PUSHs(sv_2mortal(sv));
  3759.             }
  3760.         }
  3761.         }
  3762.         break;
  3763.     case 'i':
  3764.         along = (strend - s) / sizeof(int);
  3765.         if (len > along)
  3766.         len = along;
  3767.         if (checksum) {
  3768.         while (len-- > 0) {
  3769.             Copy(s, &aint, 1, int);
  3770.             s += sizeof(int);
  3771.             if (checksum > 32)
  3772.             cdouble += (NV)aint;
  3773.             else
  3774.             culong += aint;
  3775.         }
  3776.         }
  3777.         else {
  3778.         EXTEND(SP, len);
  3779.         EXTEND_MORTAL(len);
  3780.         while (len-- > 0) {
  3781.             Copy(s, &aint, 1, int);
  3782.             s += sizeof(int);
  3783.             sv = NEWSV(40, 0);
  3784. #ifdef __osf__
  3785.                     /* Without the dummy below unpack("i", pack("i",-1))
  3786.                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
  3787.                      * cc with optimization turned on.
  3788.              *
  3789.              * The bug was detected in
  3790.              * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
  3791.              * with optimization (-O4) turned on.
  3792.              * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
  3793.              * does not have this problem even with -O4.
  3794.              *
  3795.              * This bug was reported as DECC_BUGS 1431
  3796.              * and tracked internally as GEM_BUGS 7775.
  3797.              *
  3798.              * The bug is fixed in
  3799.              * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
  3800.              * UNIX V4.0F support:   DEC C V5.9-006 or later
  3801.              * UNIX V4.0E support:   DEC C V5.8-011 or later
  3802.              * and also in DTK.
  3803.              *
  3804.              * See also few lines later for the same bug.
  3805.              */
  3806.                     (aint) ?
  3807.                 sv_setiv(sv, (IV)aint) :
  3808. #endif
  3809.             sv_setiv(sv, (IV)aint);
  3810.             PUSHs(sv_2mortal(sv));
  3811.         }
  3812.         }
  3813.         break;
  3814.     case 'I':
  3815.         along = (strend - s) / sizeof(unsigned int);
  3816.         if (len > along)
  3817.         len = along;
  3818.         if (checksum) {
  3819.         while (len-- > 0) {
  3820.             Copy(s, &auint, 1, unsigned int);
  3821.             s += sizeof(unsigned int);
  3822.             if (checksum > 32)
  3823.             cdouble += (NV)auint;
  3824.             else
  3825.             culong += auint;
  3826.         }
  3827.         }
  3828.         else {
  3829.         EXTEND(SP, len);
  3830.         EXTEND_MORTAL(len);
  3831.         while (len-- > 0) {
  3832.             Copy(s, &auint, 1, unsigned int);
  3833.             s += sizeof(unsigned int);
  3834.             sv = NEWSV(41, 0);
  3835. #ifdef __osf__
  3836.                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
  3837.                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
  3838.              * See details few lines earlier. */
  3839.                     (auint) ?
  3840.                 sv_setuv(sv, (UV)auint) :
  3841. #endif
  3842.             sv_setuv(sv, (UV)auint);
  3843.             PUSHs(sv_2mortal(sv));
  3844.         }
  3845.         }
  3846.         break;
  3847.     case 'l':
  3848. #if LONGSIZE == SIZE32
  3849.         along = (strend - s) / SIZE32;
  3850. #else
  3851.         along = (strend - s) / (natint ? sizeof(long) : SIZE32);
  3852. #endif
  3853.         if (len > along)
  3854.         len = along;
  3855.         if (checksum) {
  3856. #if LONGSIZE != SIZE32
  3857.         if (natint) {
  3858.             long along;
  3859.             while (len-- > 0) {
  3860.             COPYNN(s, &along, sizeof(long));
  3861.             s += sizeof(long);
  3862.             if (checksum > 32)
  3863.                 cdouble += (NV)along;
  3864.             else
  3865.                 culong += along;
  3866.             }
  3867.         }
  3868.         else
  3869. #endif
  3870.                 {
  3871.             while (len-- > 0) {
  3872.             COPY32(s, &along);
  3873. #if LONGSIZE > SIZE32
  3874.             if (along > 2147483647)
  3875.               along -= 4294967296;
  3876. #endif
  3877.             s += SIZE32;
  3878.             if (checksum > 32)
  3879.                 cdouble += (NV)along;
  3880.             else
  3881.                 culong += along;
  3882.             }
  3883.         }
  3884.         }
  3885.         else {
  3886.         EXTEND(SP, len);
  3887.         EXTEND_MORTAL(len);
  3888. #if LONGSIZE != SIZE32
  3889.         if (natint) {
  3890.             long along;
  3891.             while (len-- > 0) {
  3892.             COPYNN(s, &along, sizeof(long));
  3893.             s += sizeof(long);
  3894.             sv = NEWSV(42, 0);
  3895.             sv_setiv(sv, (IV)along);
  3896.             PUSHs(sv_2mortal(sv));
  3897.             }
  3898.         }
  3899.         else
  3900. #endif
  3901.                 {
  3902.             while (len-- > 0) {
  3903.             COPY32(s, &along);
  3904. #if LONGSIZE > SIZE32
  3905.             if (along > 2147483647)
  3906.               along -= 4294967296;
  3907. #endif
  3908.             s += SIZE32;
  3909.             sv = NEWSV(42, 0);
  3910.             sv_setiv(sv, (IV)along);
  3911.             PUSHs(sv_2mortal(sv));
  3912.             }
  3913.         }
  3914.         }
  3915.         break;
  3916.     case 'V':
  3917.     case 'N':
  3918.     case 'L':
  3919. #if LONGSIZE == SIZE32
  3920.         along = (strend - s) / SIZE32;
  3921. #else
  3922.         unatint = natint && datumtype == 'L';
  3923.         along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
  3924. #endif
  3925.         if (len > along)
  3926.         len = along;
  3927.         if (checksum) {
  3928. #if LONGSIZE != SIZE32
  3929.         if (unatint) {
  3930.             unsigned long aulong;
  3931.             while (len-- > 0) {
  3932.             COPYNN(s, &aulong, sizeof(unsigned long));
  3933.             s += sizeof(unsigned long);
  3934.             if (checksum > 32)
  3935.                 cdouble += (NV)aulong;
  3936.             else
  3937.                 culong += aulong;
  3938.             }
  3939.         }
  3940.         else
  3941. #endif
  3942.                 {
  3943.             while (len-- > 0) {
  3944.             COPY32(s, &aulong);
  3945.             s += SIZE32;
  3946. #ifdef HAS_NTOHL
  3947.             if (datumtype == 'N')
  3948.                 aulong = PerlSock_ntohl(aulong);
  3949. #endif
  3950. #ifdef HAS_VTOHL
  3951.             if (datumtype == 'V')
  3952.                 aulong = vtohl(aulong);
  3953. #endif
  3954.             if (checksum > 32)
  3955.                 cdouble += (NV)aulong;
  3956.             else
  3957.                 culong += aulong;
  3958.             }
  3959.         }
  3960.         }
  3961.         else {
  3962.         EXTEND(SP, len);
  3963.         EXTEND_MORTAL(len);
  3964. #if LONGSIZE != SIZE32
  3965.         if (unatint) {
  3966.             unsigned long aulong;
  3967.             while (len-- > 0) {
  3968.             COPYNN(s, &aulong, sizeof(unsigned long));
  3969.             s += sizeof(unsigned long);
  3970.             sv = NEWSV(43, 0);
  3971.             sv_setuv(sv, (UV)aulong);
  3972.             PUSHs(sv_2mortal(sv));
  3973.             }
  3974.         }
  3975.         else
  3976. #endif
  3977.                 {
  3978.             while (len-- > 0) {
  3979.             COPY32(s, &aulong);
  3980.             s += SIZE32;
  3981. #ifdef HAS_NTOHL
  3982.             if (datumtype == 'N')
  3983.                 aulong = PerlSock_ntohl(aulong);
  3984. #endif
  3985. #ifdef HAS_VTOHL
  3986.             if (datumtype == 'V')
  3987.                 aulong = vtohl(aulong);
  3988. #endif
  3989.             sv = NEWSV(43, 0);
  3990.             sv_setuv(sv, (UV)aulong);
  3991.             PUSHs(sv_2mortal(sv));
  3992.             }
  3993.         }
  3994.         }
  3995.         break;
  3996.     case 'p':
  3997.         along = (strend - s) / sizeof(char*);
  3998.         if (len > along)
  3999.         len = along;
  4000.         EXTEND(SP, len);
  4001.         EXTEND_MORTAL(len);
  4002.         while (len-- > 0) {
  4003.         if (sizeof(char*) > strend - s)
  4004.             break;
  4005.         else {
  4006.             Copy(s, &aptr, 1, char*);
  4007.             s += sizeof(char*);
  4008.         }
  4009.         sv = NEWSV(44, 0);
  4010.         if (aptr)
  4011.             sv_setpv(sv, aptr);
  4012.         PUSHs(sv_2mortal(sv));
  4013.         }
  4014.         break;
  4015.     case 'w':
  4016.         EXTEND(SP, len);
  4017.         EXTEND_MORTAL(len);
  4018.         {
  4019.         UV auv = 0;
  4020.         U32 bytes = 0;
  4021.         
  4022.         while ((len > 0) && (s < strend)) {
  4023.             auv = (auv << 7) | (*s & 0x7f);
  4024.             if (!(*s++ & 0x80)) {
  4025.             bytes = 0;
  4026.             sv = NEWSV(40, 0);
  4027.             sv_setuv(sv, auv);
  4028.             PUSHs(sv_2mortal(sv));
  4029.             len--;
  4030.             auv = 0;
  4031.             }
  4032.             else if (++bytes >= sizeof(UV)) {    /* promote to string */
  4033.             char *t;
  4034.             STRLEN n_a;
  4035.  
  4036.             sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
  4037.             while (s < strend) {
  4038.                 sv = mul128(sv, *s & 0x7f);
  4039.                 if (!(*s++ & 0x80)) {
  4040.                 bytes = 0;
  4041.                 break;
  4042.                 }
  4043.             }
  4044.             t = SvPV(sv, n_a);
  4045.             while (*t == '0')
  4046.                 t++;
  4047.             sv_chop(sv, t);
  4048.             PUSHs(sv_2mortal(sv));
  4049.             len--;
  4050.             auv = 0;
  4051.             }
  4052.         }
  4053.         if ((s >= strend) && bytes)
  4054.             DIE(aTHX_ "Unterminated compressed integer");
  4055.         }
  4056.         break;
  4057.     case 'P':
  4058.         EXTEND(SP, 1);
  4059.         if (sizeof(char*) > strend - s)
  4060.         break;
  4061.         else {
  4062.         Copy(s, &aptr, 1, char*);
  4063.         s += sizeof(char*);
  4064.         }
  4065.         sv = NEWSV(44, 0);
  4066.         if (aptr)
  4067.         sv_setpvn(sv, aptr, len);
  4068.         PUSHs(sv_2mortal(sv));
  4069.         break;
  4070. #ifdef HAS_QUAD
  4071.     case 'q':
  4072.         along = (strend - s) / sizeof(Quad_t);
  4073.         if (len > along)
  4074.         len = along;
  4075.         EXTEND(SP, len);
  4076.         EXTEND_MORTAL(len);
  4077.         while (len-- > 0) {
  4078.         if (s + sizeof(Quad_t) > strend)
  4079.             aquad = 0;
  4080.         else {
  4081.             Copy(s, &aquad, 1, Quad_t);
  4082.             s += sizeof(Quad_t);
  4083.         }
  4084.         sv = NEWSV(42, 0);
  4085.         if (aquad >= IV_MIN && aquad <= IV_MAX)
  4086.             sv_setiv(sv, (IV)aquad);
  4087.         else
  4088.             sv_setnv(sv, (NV)aquad);
  4089.         PUSHs(sv_2mortal(sv));
  4090.         }
  4091.         break;
  4092.     case 'Q':
  4093.         along = (strend - s) / sizeof(Quad_t);
  4094.         if (len > along)
  4095.         len = along;
  4096.         EXTEND(SP, len);
  4097.         EXTEND_MORTAL(len);
  4098.         while (len-- > 0) {
  4099.         if (s + sizeof(Uquad_t) > strend)
  4100.             auquad = 0;
  4101.         else {
  4102.             Copy(s, &auquad, 1, Uquad_t);
  4103.             s += sizeof(Uquad_t);
  4104.         }
  4105.         sv = NEWSV(43, 0);
  4106.         if (auquad <= UV_MAX)
  4107.             sv_setuv(sv, (UV)auquad);
  4108.         else
  4109.             sv_setnv(sv, (NV)auquad);
  4110.         PUSHs(sv_2mortal(sv));
  4111.         }
  4112.         break;
  4113. #endif
  4114.     /* float and double added gnb@melba.bby.oz.au 22/11/89 */
  4115.     case 'f':
  4116.     case 'F':
  4117.         along = (strend - s) / sizeof(float);
  4118.         if (len > along)
  4119.         len = along;
  4120.         if (checksum) {
  4121.         while (len-- > 0) {
  4122.             Copy(s, &afloat, 1, float);
  4123.             s += sizeof(float);
  4124.             cdouble += afloat;
  4125.         }
  4126.         }
  4127.         else {
  4128.         EXTEND(SP, len);
  4129.         EXTEND_MORTAL(len);
  4130.         while (len-- > 0) {
  4131.             Copy(s, &afloat, 1, float);
  4132.             s += sizeof(float);
  4133.             sv = NEWSV(47, 0);
  4134.             sv_setnv(sv, (NV)afloat);
  4135.             PUSHs(sv_2mortal(sv));
  4136.         }
  4137.         }
  4138.         break;
  4139.     case 'd':
  4140.     case 'D':
  4141.         along = (strend - s) / sizeof(double);
  4142.         if (len > along)
  4143.         len = along;
  4144.         if (checksum) {
  4145.         while (len-- > 0) {
  4146.             Copy(s, &adouble, 1, double);
  4147.             s += sizeof(double);
  4148.             cdouble += adouble;
  4149.         }
  4150.         }
  4151.         else {
  4152.         EXTEND(SP, len);
  4153.         EXTEND_MORTAL(len);
  4154.         while (len-- > 0) {
  4155.             Copy(s, &adouble, 1, double);
  4156.             s += sizeof(double);
  4157.             sv = NEWSV(48, 0);
  4158.             sv_setnv(sv, (NV)adouble);
  4159.             PUSHs(sv_2mortal(sv));
  4160.         }
  4161.         }
  4162.         break;
  4163.     case 'u':
  4164.         /* MKS:
  4165.          * Initialise the decode mapping.  By using a table driven
  4166.              * algorithm, the code will be character-set independent
  4167.              * (and just as fast as doing character arithmetic)
  4168.              */
  4169.             if (PL_uudmap['M'] == 0) {
  4170.                 int i;
  4171.  
  4172.                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
  4173.                     PL_uudmap[(U8)PL_uuemap[i]] = i;
  4174.                 /*
  4175.                  * Because ' ' and '`' map to the same value,
  4176.                  * we need to decode them both the same.
  4177.                  */
  4178.                 PL_uudmap[' '] = 0;
  4179.             }
  4180.  
  4181.         along = (strend - s) * 3 / 4;
  4182.         sv = NEWSV(42, along);
  4183.         if (along)
  4184.         SvPOK_on(sv);
  4185.         while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
  4186.         I32 a, b, c, d;
  4187.         char hunk[4];
  4188.  
  4189.         hunk[3] = '\0';
  4190.         len = PL_uudmap[*(U8*)s++] & 077;
  4191.         while (len > 0) {
  4192.             if (s < strend && ISUUCHAR(*s))
  4193.             a = PL_uudmap[*(U8*)s++] & 077;
  4194.              else
  4195.              a = 0;
  4196.             if (s < strend && ISUUCHAR(*s))
  4197.             b = PL_uudmap[*(U8*)s++] & 077;
  4198.              else
  4199.              b = 0;
  4200.             if (s < strend && ISUUCHAR(*s))
  4201.             c = PL_uudmap[*(U8*)s++] & 077;
  4202.              else
  4203.              c = 0;
  4204.             if (s < strend && ISUUCHAR(*s))
  4205.             d = PL_uudmap[*(U8*)s++] & 077;
  4206.             else
  4207.             d = 0;
  4208.             hunk[0] = (a << 2) | (b >> 4);
  4209.             hunk[1] = (b << 4) | (c >> 2);
  4210.             hunk[2] = (c << 6) | d;
  4211.             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
  4212.             len -= 3;
  4213.         }
  4214.         if (*s == '\n')
  4215.             s++;
  4216.         else if (s[1] == '\n')        /* possible checksum byte */
  4217.             s += 2;
  4218.         }
  4219.         XPUSHs(sv_2mortal(sv));
  4220.         break;
  4221.     }
  4222.     if (checksum) {
  4223.         sv = NEWSV(42, 0);
  4224.         if (strchr("fFdD", datumtype) ||
  4225.           (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
  4226.         NV trouble;
  4227.  
  4228.         adouble = 1.0;
  4229.         while (checksum >= 16) {
  4230.             checksum -= 16;
  4231.             adouble *= 65536.0;
  4232.         }
  4233.         while (checksum >= 4) {
  4234.             checksum -= 4;
  4235.             adouble *= 16.0;
  4236.         }
  4237.         while (checksum--)
  4238.             adouble *= 2.0;
  4239.         along = (1 << checksum) - 1;
  4240.         while (cdouble < 0.0)
  4241.             cdouble += adouble;
  4242.         cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
  4243.         sv_setnv(sv, cdouble);
  4244.         }
  4245.         else {
  4246.         if (checksum < 32) {
  4247.             aulong = (1 << checksum) - 1;
  4248.             culong &= aulong;
  4249.         }
  4250.         sv_setuv(sv, (UV)culong);
  4251.         }
  4252.         XPUSHs(sv_2mortal(sv));
  4253.         checksum = 0;
  4254.     }
  4255.     }
  4256.     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
  4257.     PUSHs(&PL_sv_undef);
  4258.     RETURN;
  4259. }
  4260.  
  4261. STATIC void
  4262. S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
  4263. {
  4264.     char hunk[5];
  4265.  
  4266.     *hunk = PL_uuemap[len];
  4267.     sv_catpvn(sv, hunk, 1);
  4268.     hunk[4] = '\0';
  4269.     while (len > 2) {
  4270.     hunk[0] = PL_uuemap[(077 & (*s >> 2))];
  4271.     hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
  4272.     hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
  4273.     hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
  4274.     sv_catpvn(sv, hunk, 4);
  4275.     s += 3;
  4276.     len -= 3;
  4277.     }
  4278.     if (len > 0) {
  4279.     char r = (len > 1 ? s[1] : '\0');
  4280.     hunk[0] = PL_uuemap[(077 & (*s >> 2))];
  4281.     hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
  4282.     hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
  4283.     hunk[3] = PL_uuemap[0];
  4284.     sv_catpvn(sv, hunk, 4);
  4285.     }
  4286.     sv_catpvn(sv, "\n", 1);
  4287. }
  4288.  
  4289. STATIC SV *
  4290. S_is_an_int(pTHX_ char *s, STRLEN l)
  4291. {
  4292.   STRLEN     n_a;
  4293.   SV             *result = newSVpvn(s, l);
  4294.   char           *result_c = SvPV(result, n_a);    /* convenience */
  4295.   char           *out = result_c;
  4296.   bool            skip = 1;
  4297.   bool            ignore = 0;
  4298.  
  4299.   while (*s) {
  4300.     switch (*s) {
  4301.     case ' ':
  4302.       break;
  4303.     case '+':
  4304.       if (!skip) {
  4305.     SvREFCNT_dec(result);
  4306.     return (NULL);
  4307.       }
  4308.       break;
  4309.     case '0':
  4310.     case '1':
  4311.     case '2':
  4312.     case '3':
  4313.     case '4':
  4314.     case '5':
  4315.     case '6':
  4316.     case '7':
  4317.     case '8':
  4318.     case '9':
  4319.       skip = 0;
  4320.       if (!ignore) {
  4321.     *(out++) = *s;
  4322.       }
  4323.       break;
  4324.     case '.':
  4325.       ignore = 1;
  4326.       break;
  4327.     default:
  4328.       SvREFCNT_dec(result);
  4329.       return (NULL);
  4330.     }
  4331.     s++;
  4332.   }
  4333.   *(out++) = '\0';
  4334.   SvCUR_set(result, out - result_c);
  4335.   return (result);
  4336. }
  4337.  
  4338. /* pnum must be '\0' terminated */
  4339. STATIC int
  4340. S_div128(pTHX_ SV *pnum, bool *done)
  4341. {
  4342.   STRLEN          len;
  4343.   char           *s = SvPV(pnum, len);
  4344.   int             m = 0;
  4345.   int             r = 0;
  4346.   char           *t = s;
  4347.  
  4348.   *done = 1;
  4349.   while (*t) {
  4350.     int             i;
  4351.  
  4352.     i = m * 10 + (*t - '0');
  4353.     m = i & 0x7F;
  4354.     r = (i >> 7);        /* r < 10 */
  4355.     if (r) {
  4356.       *done = 0;
  4357.     }
  4358.     *(t++) = '0' + r;
  4359.   }
  4360.   *(t++) = '\0';
  4361.   SvCUR_set(pnum, (STRLEN) (t - s));
  4362.   return (m);
  4363. }
  4364.  
  4365.  
  4366. PP(pp_pack)
  4367. {
  4368.     djSP; dMARK; dORIGMARK; dTARGET;
  4369.     register SV *cat = TARG;
  4370.     register I32 items;
  4371.     STRLEN fromlen;
  4372.     register char *pat = SvPVx(*++MARK, fromlen);
  4373.     register char *patend = pat + fromlen;
  4374.     register I32 len;
  4375.     I32 datumtype;
  4376.     SV *fromstr;
  4377.     /*SUPPRESS 442*/
  4378.     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
  4379.     static char *space10 = "          ";
  4380.  
  4381.     /* These must not be in registers: */
  4382.     char achar;
  4383.     I16 ashort;
  4384.     int aint;
  4385.     unsigned int auint;
  4386.     I32 along;
  4387.     U32 aulong;
  4388. #ifdef HAS_QUAD
  4389.     Quad_t aquad;
  4390.     Uquad_t auquad;
  4391. #endif
  4392.     char *aptr;
  4393.     float afloat;
  4394.     double adouble;
  4395.     int commas = 0;
  4396. #ifdef PERL_NATINT_PACK
  4397.     int natint;        /* native integer */
  4398. #endif
  4399.  
  4400.     items = SP - MARK;
  4401.     MARK++;
  4402.     sv_setpvn(cat, "", 0);
  4403.     while (pat < patend) {
  4404.     SV *lengthcode = Nullsv;
  4405. #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
  4406.     datumtype = *pat++ & 0xFF;
  4407. #ifdef PERL_NATINT_PACK
  4408.     natint = 0;
  4409. #endif
  4410.     if (isSPACE(datumtype))
  4411.         continue;
  4412.     if (datumtype == '#') {
  4413.         while (pat < patend && *pat != '\n')
  4414.         pat++;
  4415.         continue;
  4416.     }
  4417.         if (*pat == '!') {
  4418.         char *natstr = "sSiIlL";
  4419.  
  4420.         if (strchr(natstr, datumtype)) {
  4421. #ifdef PERL_NATINT_PACK
  4422.         natint = 1;
  4423. #endif
  4424.         pat++;
  4425.         }
  4426.         else
  4427.         DIE(aTHX_ "'!' allowed only after types %s", natstr);
  4428.     }
  4429.     if (*pat == '*') {
  4430.         len = strchr("@Xxu", datumtype) ? 0 : items;
  4431.         pat++;
  4432.     }
  4433.     else if (isDIGIT(*pat)) {
  4434.         len = *pat++ - '0';
  4435.         while (isDIGIT(*pat)) {
  4436.         len = (len * 10) + (*pat++ - '0');
  4437.         if (len < 0)
  4438.             DIE(aTHX_ "Repeat count in pack overflows");
  4439.         }
  4440.     }
  4441.     else
  4442.         len = 1;
  4443.     if (*pat == '/') {
  4444.         ++pat;
  4445.         if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
  4446.         DIE(aTHX_ "/ must be followed by a*, A* or Z*");
  4447.         lengthcode = sv_2mortal(newSViv(sv_len(items > 0
  4448.                            ? *MARK : &PL_sv_no)));
  4449.     }
  4450.     switch(datumtype) {
  4451.     default:
  4452.         DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
  4453.     case ',': /* grandfather in commas but with a warning */
  4454.         if (commas++ == 0 && ckWARN(WARN_PACK))
  4455.         Perl_warner(aTHX_ WARN_PACK,
  4456.                 "Invalid type in pack: '%c'", (int)datumtype);
  4457.         break;
  4458.     case '%':
  4459.         DIE(aTHX_ "%% may only be used in unpack");
  4460.     case '@':
  4461.         len -= SvCUR(cat);
  4462.         if (len > 0)
  4463.         goto grow;
  4464.         len = -len;
  4465.         if (len > 0)
  4466.         goto shrink;
  4467.         break;
  4468.     case 'X':
  4469.       shrink:
  4470.         if (SvCUR(cat) < len)
  4471.         DIE(aTHX_ "X outside of string");
  4472.         SvCUR(cat) -= len;
  4473.         *SvEND(cat) = '\0';
  4474.         break;
  4475.     case 'x':
  4476.       grow:
  4477.         while (len >= 10) {
  4478.         sv_catpvn(cat, null10, 10);
  4479.         len -= 10;
  4480.         }
  4481.         sv_catpvn(cat, null10, len);
  4482.         break;
  4483.     case 'A':
  4484.     case 'Z':
  4485.     case 'a':
  4486.         fromstr = NEXTFROM;
  4487.         aptr = SvPV(fromstr, fromlen);
  4488.         if (pat[-1] == '*') {
  4489.         len = fromlen;
  4490.         if (datumtype == 'Z')
  4491.             ++len;
  4492.         }
  4493.         if (fromlen >= len) {
  4494.         sv_catpvn(cat, aptr, len);
  4495.         if (datumtype == 'Z')
  4496.             *(SvEND(cat)-1) = '\0';
  4497.         }
  4498.         else {
  4499.         sv_catpvn(cat, aptr, fromlen);
  4500.         len -= fromlen;
  4501.         if (datumtype == 'A') {
  4502.             while (len >= 10) {
  4503.             sv_catpvn(cat, space10, 10);
  4504.             len -= 10;
  4505.             }
  4506.             sv_catpvn(cat, space10, len);
  4507.         }
  4508.         else {
  4509.             while (len >= 10) {
  4510.             sv_catpvn(cat, null10, 10);
  4511.             len -= 10;
  4512.             }
  4513.             sv_catpvn(cat, null10, len);
  4514.         }
  4515.         }
  4516.         break;
  4517.     case 'B':
  4518.     case 'b':
  4519.         {
  4520.         register char *str;
  4521.         I32 saveitems;
  4522.  
  4523.         fromstr = NEXTFROM;
  4524.         saveitems = items;
  4525.         str = SvPV(fromstr, fromlen);
  4526.         if (pat[-1] == '*')
  4527.             len = fromlen;
  4528.         aint = SvCUR(cat);
  4529.         SvCUR(cat) += (len+7)/8;
  4530.         SvGROW(cat, SvCUR(cat) + 1);
  4531.         aptr = SvPVX(cat) + aint;
  4532.         if (len > fromlen)
  4533.             len = fromlen;
  4534.         aint = len;
  4535.         items = 0;
  4536.         if (datumtype == 'B') {
  4537.             for (len = 0; len++ < aint;) {
  4538.             items |= *str++ & 1;
  4539.             if (len & 7)
  4540.                 items <<= 1;
  4541.             else {
  4542.                 *aptr++ = items & 0xff;
  4543.                 items = 0;
  4544.             }
  4545.             }
  4546.         }
  4547.         else {
  4548.             for (len = 0; len++ < aint;) {
  4549.             if (*str++ & 1)
  4550.                 items |= 128;
  4551.             if (len & 7)
  4552.                 items >>= 1;
  4553.             else {
  4554.                 *aptr++ = items & 0xff;
  4555.                 items = 0;
  4556.             }
  4557.             }
  4558.         }
  4559.         if (aint & 7) {
  4560.             if (datumtype == 'B')
  4561.             items <<= 7 - (aint & 7);
  4562.             else
  4563.             items >>= 7 - (aint & 7);
  4564.             *aptr++ = items & 0xff;
  4565.         }
  4566.         str = SvPVX(cat) + SvCUR(cat);
  4567.         while (aptr <= str)
  4568.             *aptr++ = '\0';
  4569.  
  4570.         items = saveitems;
  4571.         }
  4572.         break;
  4573.     case 'H':
  4574.     case 'h':
  4575.         {
  4576.         register char *str;
  4577.         I32 saveitems;
  4578.  
  4579.         fromstr = NEXTFROM;
  4580.         saveitems = items;
  4581.         str = SvPV(fromstr, fromlen);
  4582.         if (pat[-1] == '*')
  4583.             len = fromlen;
  4584.         aint = SvCUR(cat);
  4585.         SvCUR(cat) += (len+1)/2;
  4586.         SvGROW(cat, SvCUR(cat) + 1);
  4587.         aptr = SvPVX(cat) + aint;
  4588.         if (len > fromlen)
  4589.             len = fromlen;
  4590.         aint = len;
  4591.         items = 0;
  4592.         if (datumtype == 'H') {
  4593.             for (len = 0; len++ < aint;) {
  4594.             if (isALPHA(*str))
  4595.                 items |= ((*str++ & 15) + 9) & 15;
  4596.             else
  4597.                 items |= *str++ & 15;
  4598.             if (len & 1)
  4599.                 items <<= 4;
  4600.             else {
  4601.                 *aptr++ = items & 0xff;
  4602.                 items = 0;
  4603.             }
  4604.             }
  4605.         }
  4606.         else {
  4607.             for (len = 0; len++ < aint;) {
  4608.             if (isALPHA(*str))
  4609.                 items |= (((*str++ & 15) + 9) & 15) << 4;
  4610.             else
  4611.                 items |= (*str++ & 15) << 4;
  4612.             if (len & 1)
  4613.                 items >>= 4;
  4614.             else {
  4615.                 *aptr++ = items & 0xff;
  4616.                 items = 0;
  4617.             }
  4618.             }
  4619.         }
  4620.         if (aint & 1)
  4621.             *aptr++ = items & 0xff;
  4622.         str = SvPVX(cat) + SvCUR(cat);
  4623.         while (aptr <= str)
  4624.             *aptr++ = '\0';
  4625.  
  4626.         items = saveitems;
  4627.         }
  4628.         break;
  4629.     case 'C':
  4630.     case 'c':
  4631.         while (len-- > 0) {
  4632.         fromstr = NEXTFROM;
  4633.         aint = SvIV(fromstr);
  4634.         achar = aint;
  4635.         sv_catpvn(cat, &achar, sizeof(char));
  4636.         }
  4637.         break;
  4638.     case 'U':
  4639.         while (len-- > 0) {
  4640.         fromstr = NEXTFROM;
  4641.         auint = SvUV(fromstr);
  4642.         SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
  4643.         SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
  4644.                    - SvPVX(cat));
  4645.         }
  4646.         *SvEND(cat) = '\0';
  4647.         break;
  4648.     /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
  4649.     case 'f':
  4650.     case 'F':
  4651.         while (len-- > 0) {
  4652.         fromstr = NEXTFROM;
  4653.         afloat = (float)SvNV(fromstr);
  4654.         sv_catpvn(cat, (char *)&afloat, sizeof (float));
  4655.         }
  4656.         break;
  4657.     case 'd':
  4658.     case 'D':
  4659.         while (len-- > 0) {
  4660.         fromstr = NEXTFROM;
  4661.         adouble = (double)SvNV(fromstr);
  4662.         sv_catpvn(cat, (char *)&adouble, sizeof (double));
  4663.         }
  4664.         break;
  4665.     case 'n':
  4666.         while (len-- > 0) {
  4667.         fromstr = NEXTFROM;
  4668.         ashort = (I16)SvIV(fromstr);
  4669. #ifdef HAS_HTONS
  4670.         ashort = PerlSock_htons(ashort);
  4671. #endif
  4672.         CAT16(cat, &ashort);
  4673.         }
  4674.         break;
  4675.     case 'v':
  4676.         while (len-- > 0) {
  4677.         fromstr = NEXTFROM;
  4678.         ashort = (I16)SvIV(fromstr);
  4679. #ifdef HAS_HTOVS
  4680.         ashort = htovs(ashort);
  4681. #endif
  4682.         CAT16(cat, &ashort);
  4683.         }
  4684.         break;
  4685.     case 'S':
  4686. #if SHORTSIZE != SIZE16
  4687.         if (natint) {
  4688.         unsigned short aushort;
  4689.  
  4690.         while (len-- > 0) {
  4691.             fromstr = NEXTFROM;
  4692.             aushort = SvUV(fromstr);
  4693.             sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
  4694.         }
  4695.         }
  4696.         else
  4697. #endif
  4698.             {
  4699.         U16 aushort;
  4700.  
  4701.         while (len-- > 0) {
  4702.             fromstr = NEXTFROM;
  4703.             aushort = (U16)SvUV(fromstr);
  4704.             CAT16(cat, &aushort);
  4705.         }
  4706.  
  4707.         }
  4708.         break;
  4709.     case 's':
  4710. #if SHORTSIZE != SIZE16
  4711.         if (natint) {
  4712.         short ashort;
  4713.  
  4714.         while (len-- > 0) {
  4715.             fromstr = NEXTFROM;
  4716.             ashort = SvIV(fromstr);
  4717.             sv_catpvn(cat, (char *)&ashort, sizeof(short));
  4718.         }
  4719.         }
  4720.         else
  4721. #endif
  4722.             {
  4723.         while (len-- > 0) {
  4724.             fromstr = NEXTFROM;
  4725.             ashort = (I16)SvIV(fromstr);
  4726.             CAT16(cat, &ashort);
  4727.         }
  4728.         }
  4729.         break;
  4730.     case 'I':
  4731.         while (len-- > 0) {
  4732.         fromstr = NEXTFROM;
  4733.         auint = SvUV(fromstr);
  4734.         sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
  4735.         }
  4736.         break;
  4737.     case 'w':
  4738.             while (len-- > 0) {
  4739.         fromstr = NEXTFROM;
  4740.         adouble = Perl_floor(SvNV(fromstr));
  4741.  
  4742.         if (adouble < 0)
  4743.             DIE(aTHX_ "Cannot compress negative numbers");
  4744.  
  4745.         if (
  4746. #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  4747.             adouble <= UV_MAX_cxux
  4748. #else
  4749.             adouble <= UV_MAX
  4750. #endif
  4751.             )
  4752.         {
  4753.             char   buf[1 + sizeof(UV)];
  4754.             char  *in = buf + sizeof(buf);
  4755.             UV     auv = U_V(adouble);
  4756.  
  4757.             do {
  4758.             *--in = (auv & 0x7f) | 0x80;
  4759.             auv >>= 7;
  4760.             } while (auv);
  4761.             buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
  4762.             sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
  4763.         }
  4764.         else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
  4765.             char           *from, *result, *in;
  4766.             SV             *norm;
  4767.             STRLEN          len;
  4768.             bool            done;
  4769.  
  4770.             /* Copy string and check for compliance */
  4771.             from = SvPV(fromstr, len);
  4772.             if ((norm = is_an_int(from, len)) == NULL)
  4773.             DIE(aTHX_ "can compress only unsigned integer");
  4774.  
  4775.             New('w', result, len, char);
  4776.             in = result + len;
  4777.             done = FALSE;
  4778.             while (!done)
  4779.             *--in = div128(norm, &done) | 0x80;
  4780.             result[len - 1] &= 0x7F; /* clear continue bit */
  4781.             sv_catpvn(cat, in, (result + len) - in);
  4782.             Safefree(result);
  4783.             SvREFCNT_dec(norm);    /* free norm */
  4784.                 }
  4785.         else if (SvNOKp(fromstr)) {
  4786.             char   buf[sizeof(double) * 2];    /* 8/7 <= 2 */
  4787.             char  *in = buf + sizeof(buf);
  4788.  
  4789.             do {
  4790.             double next = floor(adouble / 128);
  4791.             *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
  4792.             if (--in < buf)  /* this cannot happen ;-) */
  4793.                 DIE(aTHX_ "Cannot compress integer");
  4794.             adouble = next;
  4795.             } while (adouble > 0);
  4796.             buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
  4797.             sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
  4798.         }
  4799.         else
  4800.             DIE(aTHX_ "Cannot compress non integer");
  4801.         }
  4802.             break;
  4803.     case 'i':
  4804.         while (len-- > 0) {
  4805.         fromstr = NEXTFROM;
  4806.         aint = SvIV(fromstr);
  4807.         sv_catpvn(cat, (char*)&aint, sizeof(int));
  4808.         }
  4809.         break;
  4810.     case 'N':
  4811.         while (len-- > 0) {
  4812.         fromstr = NEXTFROM;
  4813.         aulong = SvUV(fromstr);
  4814. #ifdef HAS_HTONL
  4815.         aulong = PerlSock_htonl(aulong);
  4816. #endif
  4817.         CAT32(cat, &aulong);
  4818.         }
  4819.         break;
  4820.     case 'V':
  4821.         while (len-- > 0) {
  4822.         fromstr = NEXTFROM;
  4823.         aulong = SvUV(fromstr);
  4824. #ifdef HAS_HTOVL
  4825.         aulong = htovl(aulong);
  4826. #endif
  4827.         CAT32(cat, &aulong);
  4828.         }
  4829.         break;
  4830.     case 'L':
  4831. #if LONGSIZE != SIZE32
  4832.         if (natint) {
  4833.         unsigned long aulong;
  4834.  
  4835.         while (len-- > 0) {
  4836.             fromstr = NEXTFROM;
  4837.             aulong = SvUV(fromstr);
  4838.             sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
  4839.         }
  4840.         }
  4841.         else
  4842. #endif
  4843.             {
  4844.         while (len-- > 0) {
  4845.             fromstr = NEXTFROM;
  4846.             aulong = SvUV(fromstr);
  4847.             CAT32(cat, &aulong);
  4848.         }
  4849.         }
  4850.         break;
  4851.     case 'l':
  4852. #if LONGSIZE != SIZE32
  4853.         if (natint) {
  4854.         long along;
  4855.  
  4856.         while (len-- > 0) {
  4857.             fromstr = NEXTFROM;
  4858.             along = SvIV(fromstr);
  4859.             sv_catpvn(cat, (char *)&along, sizeof(long));
  4860.         }
  4861.         }
  4862.         else
  4863. #endif
  4864.             {
  4865.         while (len-- > 0) {
  4866.             fromstr = NEXTFROM;
  4867.             along = SvIV(fromstr);
  4868.             CAT32(cat, &along);
  4869.         }
  4870.         }
  4871.         break;
  4872. #ifdef HAS_QUAD
  4873.     case 'Q':
  4874.         while (len-- > 0) {
  4875.         fromstr = NEXTFROM;
  4876.         auquad = (Uquad_t)SvUV(fromstr);
  4877.         sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
  4878.         }
  4879.         break;
  4880.     case 'q':
  4881.         while (len-- > 0) {
  4882.         fromstr = NEXTFROM;
  4883.         aquad = (Quad_t)SvIV(fromstr);
  4884.         sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
  4885.         }
  4886.         break;
  4887. #endif
  4888.     case 'P':
  4889.         len = 1;        /* assume SV is correct length */
  4890.         /* FALL THROUGH */
  4891.     case 'p':
  4892.         while (len-- > 0) {
  4893.         fromstr = NEXTFROM;
  4894.         if (fromstr == &PL_sv_undef)
  4895.             aptr = NULL;
  4896.         else {
  4897.             STRLEN n_a;
  4898.             /* XXX better yet, could spirit away the string to
  4899.              * a safe spot and hang on to it until the result
  4900.              * of pack() (and all copies of the result) are
  4901.              * gone.
  4902.              */
  4903.             if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
  4904.                         || (SvPADTMP(fromstr)
  4905.                             && !SvREADONLY(fromstr))))
  4906.             {
  4907.             Perl_warner(aTHX_ WARN_PACK,
  4908.                 "Attempt to pack pointer to temporary value");
  4909.             }
  4910.             if (SvPOK(fromstr) || SvNIOK(fromstr))
  4911.             aptr = SvPV(fromstr,n_a);
  4912.             else
  4913.             aptr = SvPV_force(fromstr,n_a);
  4914.         }
  4915.         sv_catpvn(cat, (char*)&aptr, sizeof(char*));
  4916.         }
  4917.         break;
  4918.     case 'u':
  4919.         fromstr = NEXTFROM;
  4920.         aptr = SvPV(fromstr, fromlen);
  4921.         SvGROW(cat, fromlen * 4 / 3);
  4922.         if (len <= 1)
  4923.         len = 45;
  4924.         else
  4925.         len = len / 3 * 3;
  4926.         while (fromlen > 0) {
  4927.         I32 todo;
  4928.  
  4929.         if (fromlen > len)
  4930.             todo = len;
  4931.         else
  4932.             todo = fromlen;
  4933.         doencodes(cat, aptr, todo);
  4934.         fromlen -= todo;
  4935.         aptr += todo;
  4936.         }
  4937.         break;
  4938.     }
  4939.     }
  4940.     SvSETMAGIC(cat);
  4941.     SP = ORIGMARK;
  4942.     PUSHs(cat);
  4943.     RETURN;
  4944. }
  4945. #undef NEXTFROM
  4946.  
  4947.  
  4948. PP(pp_split)
  4949. {
  4950.     djSP; dTARG;
  4951.     AV *ary;
  4952.     register I32 limit = POPi;            /* note, negative is forever */
  4953.     SV *sv = POPs;
  4954.     STRLEN len;
  4955.     register char *s = SvPV(sv, len);
  4956.     char *strend = s + len;
  4957.     register PMOP *pm;
  4958.     register REGEXP *rx;
  4959.     register SV *dstr;
  4960.     register char *m;
  4961.     I32 iters = 0;
  4962.     I32 maxiters = (strend - s) + 10;
  4963.     I32 i;
  4964.     char *orig;
  4965.     I32 origlimit = limit;
  4966.     I32 realarray = 0;
  4967.     I32 base;
  4968.     AV *oldstack = PL_curstack;
  4969.     I32 gimme = GIMME_V;
  4970.     I32 oldsave = PL_savestack_ix;
  4971.     I32 make_mortal = 1;
  4972.     MAGIC *mg = (MAGIC *) NULL;
  4973.  
  4974. #ifdef DEBUGGING
  4975.     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
  4976. #else
  4977.     pm = (PMOP*)POPs;
  4978. #endif
  4979.     if (!pm || !s)
  4980.     DIE(aTHX_ "panic: do_split");
  4981.     rx = pm->op_pmregexp;
  4982.  
  4983.     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
  4984.          (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
  4985.  
  4986.     if (pm->op_pmreplroot) {
  4987. #ifdef USE_ITHREADS
  4988.     ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
  4989. #else
  4990.     ary = GvAVn((GV*)pm->op_pmreplroot);
  4991. #endif
  4992.     }
  4993.     else if (gimme != G_ARRAY)
  4994. #ifdef USE_THREADS
  4995.     ary = (AV*)PL_curpad[0];
  4996. #else
  4997.     ary = GvAVn(PL_defgv);
  4998. #endif /* USE_THREADS */
  4999.     else
  5000.     ary = Nullav;
  5001.     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
  5002.     realarray = 1;
  5003.     PUTBACK;
  5004.     av_extend(ary,0);
  5005.     av_clear(ary);
  5006.     SPAGAIN;
  5007.     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
  5008.         PUSHMARK(SP);
  5009.         XPUSHs(SvTIED_obj((SV*)ary, mg));
  5010.     }
  5011.     else {
  5012.         if (!AvREAL(ary)) {
  5013.         AvREAL_on(ary);
  5014.         AvREIFY_off(ary);
  5015.         for (i = AvFILLp(ary); i >= 0; i--)
  5016.             AvARRAY(ary)[i] = &PL_sv_undef;    /* don't free mere refs */
  5017.         }
  5018.         /* temporarily switch stacks */
  5019.         SWITCHSTACK(PL_curstack, ary);
  5020.         make_mortal = 0;
  5021.     }
  5022.     }
  5023.     base = SP - PL_stack_base;
  5024.     orig = s;
  5025.     if (pm->op_pmflags & PMf_SKIPWHITE) {
  5026.     if (pm->op_pmflags & PMf_LOCALE) {
  5027.         while (isSPACE_LC(*s))
  5028.         s++;
  5029.     }
  5030.     else {
  5031.         while (isSPACE(*s))
  5032.         s++;
  5033.     }
  5034.     }
  5035.     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
  5036.     SAVEINT(PL_multiline);
  5037.     PL_multiline = pm->op_pmflags & PMf_MULTILINE;
  5038.     }
  5039.  
  5040.     if (!limit)
  5041.     limit = maxiters + 2;
  5042.     if (pm->op_pmflags & PMf_WHITE) {
  5043.     while (--limit) {
  5044.         m = s;
  5045.         while (m < strend &&
  5046.            !((pm->op_pmflags & PMf_LOCALE)
  5047.              ? isSPACE_LC(*m) : isSPACE(*m)))
  5048.         ++m;
  5049.         if (m >= strend)
  5050.         break;
  5051.  
  5052.         dstr = NEWSV(30, m-s);
  5053.         sv_setpvn(dstr, s, m-s);
  5054.         if (make_mortal)
  5055.         sv_2mortal(dstr);
  5056.         XPUSHs(dstr);
  5057.  
  5058.         s = m + 1;
  5059.         while (s < strend &&
  5060.            ((pm->op_pmflags & PMf_LOCALE)
  5061.             ? isSPACE_LC(*s) : isSPACE(*s)))
  5062.         ++s;
  5063.     }
  5064.     }
  5065.     else if (strEQ("^", rx->precomp)) {
  5066.     while (--limit) {
  5067.         /*SUPPRESS 530*/
  5068.         for (m = s; m < strend && *m != '\n'; m++) ;
  5069.         m++;
  5070.         if (m >= strend)
  5071.         break;
  5072.         dstr = NEWSV(30, m-s);
  5073.         sv_setpvn(dstr, s, m-s);
  5074.         if (make_mortal)
  5075.         sv_2mortal(dstr);
  5076.         XPUSHs(dstr);
  5077.         s = m;
  5078.     }
  5079.     }
  5080.     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
  5081.          && (rx->reganch & ROPT_CHECK_ALL)
  5082.          && !(rx->reganch & ROPT_ANCH)) {
  5083.     int tail = (rx->reganch & RE_INTUIT_TAIL);
  5084.     SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
  5085.     char c;
  5086.  
  5087.     len = rx->minlen;
  5088.     if (len == 1 && !tail) {
  5089.         c = *SvPV(csv,len);
  5090.         while (--limit) {
  5091.         /*SUPPRESS 530*/
  5092.         for (m = s; m < strend && *m != c; m++) ;
  5093.         if (m >= strend)
  5094.             break;
  5095.         dstr = NEWSV(30, m-s);
  5096.         sv_setpvn(dstr, s, m-s);
  5097.         if (make_mortal)
  5098.             sv_2mortal(dstr);
  5099.         XPUSHs(dstr);
  5100.         s = m + 1;
  5101.         }
  5102.     }
  5103.     else {
  5104. #ifndef lint
  5105.         while (s < strend && --limit &&
  5106.           (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
  5107.                  csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
  5108. #endif
  5109.         {
  5110.         dstr = NEWSV(31, m-s);
  5111.         sv_setpvn(dstr, s, m-s);
  5112.         if (make_mortal)
  5113.             sv_2mortal(dstr);
  5114.         XPUSHs(dstr);
  5115.         s = m + len;        /* Fake \n at the end */
  5116.         }
  5117.     }
  5118.     }
  5119.     else {
  5120.     maxiters += (strend - s) * rx->nparens;
  5121.     while (s < strend && --limit
  5122. /*           && (!rx->check_substr 
  5123.            || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
  5124.                          0, NULL))))
  5125. */           && CALLREGEXEC(aTHX_ rx, s, strend, orig,
  5126.                   1 /* minend */, sv, NULL, 0))
  5127.     {
  5128.         TAINT_IF(RX_MATCH_TAINTED(rx));
  5129.         if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
  5130.         m = s;
  5131.         s = orig;
  5132.         orig = rx->subbeg;
  5133.         s = orig + (m - s);
  5134.         strend = s + (strend - m);
  5135.         }
  5136.         m = rx->startp[0] + orig;
  5137.         dstr = NEWSV(32, m-s);
  5138.         sv_setpvn(dstr, s, m-s);
  5139.         if (make_mortal)
  5140.         sv_2mortal(dstr);
  5141.         XPUSHs(dstr);
  5142.         if (rx->nparens) {
  5143.         for (i = 1; i <= rx->nparens; i++) {
  5144.             s = rx->startp[i] + orig;
  5145.             m = rx->endp[i] + orig;
  5146.             if (m && s) {
  5147.             dstr = NEWSV(33, m-s);
  5148.             sv_setpvn(dstr, s, m-s);
  5149.             }
  5150.             else
  5151.             dstr = NEWSV(33, 0);
  5152.             if (make_mortal)
  5153.             sv_2mortal(dstr);
  5154.             XPUSHs(dstr);
  5155.         }
  5156.         }
  5157.         s = rx->endp[0] + orig;
  5158.     }
  5159.     }
  5160.  
  5161.     LEAVE_SCOPE(oldsave);
  5162.     iters = (SP - PL_stack_base) - base;
  5163.     if (iters > maxiters)
  5164.     DIE(aTHX_ "Split loop");
  5165.  
  5166.     /* keep field after final delim? */
  5167.     if (s < strend || (iters && origlimit)) {
  5168.     dstr = NEWSV(34, strend-s);
  5169.     sv_setpvn(dstr, s, strend-s);
  5170.     if (make_mortal)
  5171.         sv_2mortal(dstr);
  5172.     XPUSHs(dstr);
  5173.     iters++;
  5174.     }
  5175.     else if (!origlimit) {
  5176.     while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
  5177.         iters--, SP--;
  5178.     }
  5179.  
  5180.     if (realarray) {
  5181.     if (!mg) {
  5182.         SWITCHSTACK(ary, oldstack);
  5183.         if (SvSMAGICAL(ary)) {
  5184.         PUTBACK;
  5185.         mg_set((SV*)ary);
  5186.         SPAGAIN;
  5187.         }
  5188.         if (gimme == G_ARRAY) {
  5189.         EXTEND(SP, iters);
  5190.         Copy(AvARRAY(ary), SP + 1, iters, SV*);
  5191.         SP += iters;
  5192.         RETURN;
  5193.         }
  5194.     }
  5195.     else {
  5196.         PUTBACK;
  5197.         ENTER;
  5198.         call_method("PUSH",G_SCALAR|G_DISCARD);
  5199.         LEAVE;
  5200.         SPAGAIN;
  5201.         if (gimme == G_ARRAY) {
  5202.         /* EXTEND should not be needed - we just popped them */
  5203.         EXTEND(SP, iters);
  5204.         for (i=0; i < iters; i++) {
  5205.             SV **svp = av_fetch(ary, i, FALSE);
  5206.             PUSHs((svp) ? *svp : &PL_sv_undef);
  5207.         }
  5208.         RETURN;
  5209.         }
  5210.     }
  5211.     }
  5212.     else {
  5213.     if (gimme == G_ARRAY)
  5214.         RETURN;
  5215.     }
  5216.     if (iters || !pm->op_pmreplroot) {
  5217.     GETTARGET;
  5218.     PUSHi(iters);
  5219.     RETURN;
  5220.     }
  5221.     RETPUSHUNDEF;
  5222. }
  5223.  
  5224. #ifdef USE_THREADS
  5225. void
  5226. Perl_unlock_condpair(pTHX_ void *svv)
  5227. {
  5228.     dTHR;
  5229.     MAGIC *mg = mg_find((SV*)svv, 'm');
  5230.  
  5231.     if (!mg)
  5232.     Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
  5233.     MUTEX_LOCK(MgMUTEXP(mg));
  5234.     if (MgOWNER(mg) != thr)
  5235.     Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
  5236.     MgOWNER(mg) = 0;
  5237.     COND_SIGNAL(MgOWNERCONDP(mg));
  5238.     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
  5239.               PTR2UV(thr), PTR2UV(svv));)
  5240.     MUTEX_UNLOCK(MgMUTEXP(mg));
  5241. }
  5242. #endif /* USE_THREADS */
  5243.  
  5244. PP(pp_lock)
  5245. {
  5246.     djSP;
  5247.     dTOPss;
  5248.     SV *retsv = sv;
  5249. #ifdef USE_THREADS
  5250.     MAGIC *mg;
  5251.  
  5252.     if (SvROK(sv))
  5253.     sv = SvRV(sv);
  5254.  
  5255.     mg = condpair_magic(sv);
  5256.     MUTEX_LOCK(MgMUTEXP(mg));
  5257.     if (MgOWNER(mg) == thr)
  5258.     MUTEX_UNLOCK(MgMUTEXP(mg));
  5259.     else {
  5260.     while (MgOWNER(mg))
  5261.         COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
  5262.     MgOWNER(mg) = thr;
  5263.     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
  5264.                   PTR2UV(thr), PTR2UV(sv));)
  5265.     MUTEX_UNLOCK(MgMUTEXP(mg));
  5266.     SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
  5267.     }
  5268. #endif /* USE_THREADS */
  5269.     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
  5270.     || SvTYPE(retsv) == SVt_PVCV) {
  5271.     retsv = refto(retsv);
  5272.     }
  5273.     SETs(retsv);
  5274.     RETURN;
  5275. }
  5276.  
  5277. PP(pp_threadsv)
  5278. {
  5279. #ifdef USE_THREADS
  5280.     djSP;
  5281.     EXTEND(SP, 1);
  5282.     if (PL_op->op_private & OPpLVAL_INTRO)
  5283.     PUSHs(*save_threadsv(PL_op->op_targ));
  5284.     else
  5285.     PUSHs(THREADSV(PL_op->op_targ));
  5286.     RETURN;
  5287. #else
  5288.     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
  5289. #endif /* USE_THREADS */
  5290. }
  5291.